                   V. A.  C R O S S  R E F E R E N C E R  7.3
                       [2008 VA Standards & Conventions]
                  UCI: VISTA CPU: ROU    Jul 01, 2016@06:56:32

The BUILD file Data Dictionaries are being processed.

52.52 CLOZAPINE PRESCRIPTION OVERRIDES
52.54 CLOZAPINE OVERRIDE REASONS.
The option and function files are being processed.


Routines are being processed.
Routines: 6  Faux Routines: 3

PSOCLO1   PSOCLUTL  PSODRG    PSON52    PSONEW1   PSORENW0  

          Data Dictionaries
|dd52.52       |dd52.54       |opt           

--- CROSS REFERENCING ---


Compiled list of Errors and Warnings              Jul 01, 2016@06:56:32 page 1
No errors or warnings to report


--- Routine Detail   --- with REGULAR ROUTINE LISTING ---

PSOCLO1  * *  357 Lines,  13550 Bytes, Checksum: B133519703
                                                  Jul 01, 2016@06:56:32 page 2
              2376 bytes in comments
PSOCLO1  ;BHAM ISC/SAB - clozaril rx lockout routine ; 1/13/16 5:03pm
         ;;7.0;OUTPATIENT PHARMACY;**1,23,37,222,457**;DEC 1997;Build 10
         ;External reference YSCLTST2 supported by DBIA 4556
         ;Reference to ^YSCL(603.01 is supported by DBIA 2697
         ;External reference ^PS(55 supported by DBIA 2228
         ; Reference to ^XMD supported by IA #10070
         ; Reference to ^DPT supported by IA #10035
         ;MH package will authorize dispensing of the Clozapine drugs
         K ANQDATA,ANQX,ANQNO,CLOZFLG,FLG,PSONEW("SAND"),^TMP($J,"PSO")
         N X,Y,%,%DT,J,ANQ,ANQD,ANQJ,ANQRE,DTOUT,DUOUT,DIR,DIRUT,LSTFOUR,PSOYS,P
          STYPE,PSREG
         ;; START NCC REMEDIATION >> 457*RJS
         N PSMSGTXT
         I XQY0["PSO" S PSTYPE=0,PSMSGTXT="prescription"
         I XQY0["PSJ" S PSTYPE=1,PSMSGTXT="order"
         ;; END NCC REMEDIATION << 457*RJS
         ; /RBN Begin NCC unregistered bypass for PSO*457
         S CLOZFLG=0 ; Used to force start/stop dates to four days only
         I $P($G(^PS(55,DFN,"SAND")),"^")="" W !!,"*** This patient has no cloza
          pine registration number ***",! D NOREG Q:'CLOZFLG
         ;
         I $P($G(^PS(55,DFN,"SAND")),"^",2)="D" D  D NOREG Q:'CLOZFLG
         . W !!,"*** This patient has no clozapine registration number ***",!
         . W !,"*** and must be reregistered ***",!
         ;
         I $P($G(^PS(55,DFN,"SAND")),"^")["Z" S PSREG=$P($G(^PS(55,DFN,"SAND")),
          "^"),^TMP("CLOZFLG",DFN)=1
         ;/RBN End NCC unregistered paypass for PSO*457
         ;
         S PSLAST7="" ; ** NCC REMEDIATION ** 457/RTW
         S PSOYS=$$CL^YSCLTST2(DFN)
         G:+PSOYS<0 END
         S CLOZPAT=$P(PSOYS,"^",7),CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
         G:$P(PSOYS,"^")=0 OV1
         I '$G(CLOZFLG),+$G(PSOYS)=1 D  Q
         .D DSP G:+PSOYS=1 GDOSE
         I $G(CLOZFLG),+$G(PSOYS)=1 S ANQRE=8
         S X=$S(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
         D CL1^YSCLTST2(DFN,X)
         I $D(^TMP($J,"PSO")) D CHECK,OVRD
         Q
OV1      I $$OVERRIDE^YSCLTST2(DFN) S ANQRE=7,ANQX=0 W !!,"Permission to dispens
          e clozapine has been authorized by NCCC",! G OVRD
         S X=$S(CLOZPAT=2:84,CLOZPAT=1:42,1:21)
         D CL1^YSCLTST2(DFN,X)
         ;I $D(^TMP($J,"PSO")) D CHECK
         D CHECK
         I $G(ANQRE)=8 D OVRD Q
         I +$P(PSOYS,"^",2),$P(PSOYS,"^",4)<1000,$P(PSOYS,"^",4)>0 D MSG4^PSJCLO
          Z,MSG3^PSJCLOZ,MH Q
         I PSTYPE=0 D
         .I +$P(PSOYS,"^",2),'+$P(PSOYS,"^",4) D MSG9^PSJCLOZ,OVRD Q
         .I '+$P(PSOYS,"^",2),'+$P(PSOYS,"^",4) D MSG9^PSJCLOZ,OVRD Q
         .I '+$P(PSOYS,"^",2),+$P(PSOYS,"^",4) D MSG1^PSJCLOZ Q
         I PSTYPE=1 D
         .I +$P(PSOYS,"^",2),'+$P(PSOYS,"^",4) D MSG10^PSJCLOZ,OVRD Q
         .I '+$P(PSOYS,"^",2),'+$P(PSOYS,"^",4) D MSG10^PSJCLOZ,OVRD Q
         .I '+$P(PSOYS,"^",2),+$P(PSOYS,"^",4) D MSG1^PSJCLOZ Q
         ;G QU
         Q
CHECK    ;
         S:$D(^XUSEC("YSCL AUTHORIZED",DUZ)) ANQX=0 ;RTW added because of undefi
          ned ANQX error from PSGOE7.INT 3160303
         I $G(ANQRE)'=8 S ANQRE=$S('+$P(PSOYS,"^",4):9,$P(PSOYS,"^",4)<1000:7,$P
          (PSOYS,"^",2)="":9,$P(PSOYS,"^",4)<1500:10,PSLAST7["Y":9,1:0)
         S (ANQD,ANQD(1))=9999999-$P(PSOYS,"^",6) ;,X1=$P(PSOYS,"^",6),X2="-6" D
           C^%DTC S ANQD=(9999999-$P(X,"."))
         S ANQ(1)=$P(PSOYS,"^",2)_"^"_$P(PSOYS,"^",4) D
         .Q:'$D(^TMP($J,"PSO"))  ;W !,"*** No previous results to display ***",!
           Q
         .F ANQJ=2:1:4 S ANQD=$O(^TMP($J,"PSO",ANQD)) Q:'ANQD  S ANQ(ANQJ)=^(ANQ
          D),ANQD(ANQJ)=ANQD
         S ANQD=$O(ANQ(""),-1)
         I $D(PSREG),PSREG["Z",$P(PSOYS,"^",4)'>1500 W !!,"Emergency overrides f
          or non registered clozapine patients requires",!,"ANC levels greater t
          han or equal to 1500",! S ANQX=1 Q  ;;RTW NCC PSJ AND PSO
         I ANQD<2 W !,"*** No previous results to display ***",!
         Q:ANQD<2
         ;/RBN - Begin modificatons for defect 343371
         W !,"*** Last "_$S(ANQD=4:"Four ",ANQD=3:"Three ",1:"TWO ")_$P(PSOYS,"^
          ",3)_" and "_$P(PSOYS,"^",5)_" (ANC) results ***",!
         W !,?39,"WBC    ANC",!
         ;/RBN - End modifications for defect 343371
         F ANQJ=ANQD:-1:1 S ANQD=9999999-ANQD(ANQJ)_"0000" W ?5,$E(ANQD,4,5)_"/"
          _$E(ANQD,6,7)_"/"_($E(ANQD,1,3)+1700) W:ANQD["." "@",$E(ANQD,9,10),":"
          ,$E(ANQD,11,12) W ?29,"Results: "_$JUSTIFY($P(ANQ(ANQJ),"^"),4)_"   ",
          $JUSTIFY($P(ANQ(ANQJ),"^",2),4),!
         Q
OVRD     ;
         Q:$G(ANQX)
         N PSREASON
         I '$D(^XUSEC("PSOLOCKCLOZ",DUZ)) D  G EXIT
         .S ANQX=1 W !,"You Are Not Authorized to Override! See Clozapine Manage
          r with PSOLOCKCLOZ key."
         ; ** START NCC REMEDIATION ** 457/RTW
         I ANQRE W !,"Override reason: "_$P($T(@(ANQRE_"^PSOCLO1")),";;",2),! D
         .I ANQRE=10 W !,"Test ANC Results 3x weekly until ANC stabilize to grea
          ter than or equal to 1500",!
         .I ANQRE=7 D
         .W !,"Test ANC labs Daily until levels stabilize to ANC greater than or
           equal to 1000",!
         .S PSREASON=$P($T(@(ANQRE_"^PSOCLO1")),";;",2) D
         .D OVPRMPT
         .Q:$G(ANQX)
         .D OVRD2
         .Q:$G(ANQX)
         .D OVRREA
         G:$G(ANQX) EXIT
         I ANQRE=5 S DIR("A")="ANC levels are Critically low. Do you want to Can
          cel the order",DIR(0)="Y",DIR("B")="N" D ^DIR K DIR D:Y=0  I Y(0)="YES
          "!($D(DTOUT))!($D(DUOUT))!($D(DIROUT)) S ANQX=1 K DIR G EXIT
         . D MSG6^PSJCLOZ
         . W !!,"No "_PSMSGTXT_" entered!" K ANQDATA Q
         I $G(ANQRE)=8 D
         .S ANQX=0
         .S DIR("A")="Do you want to override and issue this "_PSMSGTXT,DIR(0)="
          Y",DIR("B")="N" D ^DIR I 'Y!($D(DIROUT)!($D(DTOUT))) S ANQX=1 K DIR
         .Q:$G(ANQX)
         .D OVPRMPT
         .Q:$G(ANQX)
         .D OVRD2
         .Q:$G(ANQX)
         .D OVRREA
         G:$G(ANQX) EXIT
         ;/RBN Begin modifications for new special overide condition for inpatie
          nt
         I ANQRE=9,PSTYPE=0 D
         .D OVPRMPT
         .Q:$G(ANQX)
         .D OVRD2
         .Q:$G(ANQX)
         .K DIR,DIRUT S DIR(0)="S^1:Weather Related Conditions;2:Mail Order Dela
          y;3:Inpatient Going On Leave"
         .S DIR("A")="Prescriber's reason for Special Condition Override " D ^DI
          R K DIR I $D(DIRUT) G EXIT S ANQX=1 Q
         .S PSREASON=Y(0)_": ",^TMP("CLOZFLG",DFN)=1
         .W !,PSREASON,!
         .D OVRREA
         .Q:$G(ANQX)
         .S PSREMARK=PSREASON_PSREMARK
         G:$G(ANQX) EXIT
         I ANQRE=9,PSTYPE=1 D
         .D OVPRMPT
         .Q:$G(ANQX)
         .S PSREASON="IP Order Override with Outside Lab Results: ",^TMP("CLOZFL
          G",DFN)=1
         .W !,PSREASON,!
         .D OVRD2
         .Q:$G(ANQX)
         .D OVRREA
         .Q:$G(ANQX)
         .S PSREMARK=PSREASON_PSREMARK
         G:$G(ANQX) EXIT
         I ANQRE=10 D
         .D OVPRMPT
         .Q:$G(ANQX)
         .D OVRD2
         .Q:$G(ANQX)
         .D OVRREA
         Q:$G(ANQX)
         S PSPROVID="UNKNOWN"
         I $D(ND0) S PSPROVID=$P(ND0,"^",2),PSJORN=$P(ND0,"^",21),PSJORDER("PSJO
          RN")=PSJORN
         I $D(ORO) S PSPROVID=$P(ORO,"^",4),PSJORN=$P(ORO,"^",1),PSJORDER("PSJOR
          N")=PSJORN
         I $D(DUPRX0) S PSPROVID=$P(DUPRX0,"^",4)
         ;/RBN Begin modifications for new special overide condition for inpatie
          nt
         Q:$G(ANQX)
         ;/RBN End modifications for defect 689690 PSJ*5.0*457
         S ANQX=0,PSCLPAT=DFN,ANQDATA=DUZ_"^"_PSSPHARM_"^"_ANQRE_"^"_PSREMARK_"^
          "_PSPROVID_"^"_PSCLPAT
         ; ** END NCC REMEDIATION ** 457/RTW
GDOSE    ; set variable to ask daily dose
         N PSOCD
         Q:$G(PSTYPE)
DOSE     ;
         S DIR(0)="N^12.5:3000:1",DIR("A")="CLOZAPINE dosage (mg/day) ? " D ^DIR
           K DIR G EXIT:$D(DIRUT)
         S PSOCD=X
         I PSOCD#25=0,PSOCD'<12.5,PSOCD<900 G EXIT
         I PSOCD#12.5 S DIR(0)="Y",DIR("B")="NO",DIR("A")=PSOCD_" is an unusual 
          dose.  Are you sure " D ^DIR K DIR G EXIT:$D(DIRUT) I 'Y G DOSE
         I PSOCD>900 S DIR(0)="Y",DIR("A")="Recommended maximum daily dose is 90
          0. Are you sure " D ^DIR K DIR G EXIT:$D(DIRUT) I 'Y G DOSE
EXIT     ;
         K ^TMP($J,"PSO")
         S:$D(DIRUT) ANQX=1
         I $G(ANQX) W !!,"No "_PSMSGTXT_" entered!"
         E  S PSONEW("SAND")=PSOCD_"^"_$P(PSOYS,"^",2)_"^"_($P($P(PSOYS,"^",6),"
          ."))_"^"_$P(PSOYS,"^",4)
         Q
OVPRMPT  S DIR("A")="Do you want to override and issue this "_PSMSGTXT,DIR(0)="Y
          ",DIR("B")="N" D ^DIR I 'Y!($D(DIROUT)!($D(DTOUT))) S ANQX=1 K DIR
         Q
         ;/RBN messages move to PSJCLOZ to reduce routine length to meet SACC st
          andards
         ;
MH       ;
         W !!,"Also make sure that the LAB test, ANC is set up correctly in the"
         W !,"Mental Health package using the CLOZAPINE MULTI TEST LINK option."
          ,!
         Q
DSP      ;; ** START NCC REMEDIATION ** 457 AND PSJ 327/RTW
         ;/RBN Begin change for defect 343371
         W !,"*** Most recent WBC and "_$P(PSOYS,"^",5)_" (ANC) results ***"
         ;/RBN End change for defect 343371
         ; ** END NCC REMEDIATION ** 457 AND PSJ 327/RTW
         W !,"     performed on "
         S Y=$P(PSOYS,"^",6) X ^DD("DD") W $P(Y,"@")_" are: "
         W !!,?5,$P(PSOYS,"^",3)_": "_$P(PSOYS,"^",2)
         W !,?5,"ANC: "_+$P(PSOYS,"^",4),!
         Q
DIR      ;
         W !! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DI
          R,DTOUT,DUOUT,DIRUT
         Q
         ; ** START NCC REMEDIATION ** 457/RTW
PHGRP    ;
         S PSJCNT=0 F XDUZ=0:0 S XDUZ=$O(^XUSEC("PSOLOCKCLOZ",XDUZ)) Q:XDUZ'>0  
          D
         . Q:$P(^VA(200,XDUZ,0),"^",3)=""
         . Q:$P(^VA(200,XDUZ,0),"^",7)=1
         . Q:XDUZ=DUZ
         . S PSJCNT=PSJCNT+1
         . S ^TMP("XQADUZ",$J,XDUZ)=""
         W:PSJCNT=0 "NO ACTIVE APPROVING MEMBERS AVAILABLE"
         K XDUZ
         Q
         ; ** END NCC REMEDIATION ** 457/RTW
         ;
END      ;
         D MSG5^PSJCLOZ
QU       S ANQX=1 D DIR
         Q
         ;
         ; /RBN Begin NCC weekend/new patient for PSO*7.0*457
NOREG    ; Register a new/discontinued non-registered cloz patient
         ;
         N %,FIRST,FLG,I,LAST,LSTFOUR,MSG,MSGNUM,NAME,NOW,PSO1,PSO2,PSO4,PSONAME
          ,REG,SSN,STAT,TMP1
         N TMP2,X,X1,X2XML,XMSUB,XMTEXT,YSCLFRQ
         ; Check for authorization key
         I '$D(^XUSEC("PSOLOCKCLOZ",DUZ)) D  Q
         .S ANQX=1 W !,"You Are Not Authorized to Override! See Clozapine Manage
          r with PSOLOCKCLOZ key." W:PSTYPE=1 !!,"No order entered!"
         ;
         W !,"Do you want to register this patient with a temporary local"
         W !," authorization number in the Clozapine register? Y/N  "
         S %=2
         D YN^DICN
         I %'=1 S ANQX=1 Q
         W !
         S PSO1=DFN
         S TMP1=DFN
         ; Added next six lines for the reuse of existing emergency registration
           numbers
         ;I $E($P($G(^XTMP("PSJ CLOZ",DFN)),U,2),1,2)?1A.N D  G CONT
         I $L($$CHK4REG(DFN))=7 D  G CONT
         . ;S PSO2=$P($G(^XTMP("PSJ CLOZ",DFN)),U,2)
         . S PSO2=$$CHK4REG(DFN)
         . S $P(^XTMP("PSJ CLOZ",DFN),U,3)="A"
         . S DA=$O(^YSCL(603.01,"C",DFN,""))
         . S DIK="^YSCL(603.01," D ^DIK
         . K DA,DIK
         S PSO2=$$FINDNEXT()
         I PSO2=-1 D  G END
         . W !!,"All emergency registration numbers have been used."
         . W !,"Emergency registration may no longer be done at this site",!!
CONT     S TMP2=PSO2
         S PSONAME=$P(^DPT(PSO1,0),U)
         S PSCLOZ=1
         S DFN=TMP1
         S PSO2=TMP2
         S XMSUB="ADD"
         S REG=PSO2
         ; Check if registration in file #55 failed or was terminated
         S NAME=$P(^DPT(DFN,0),"^")
         S LAST=$P(NAME,",",1)
         S FIRST=$P($P(NAME,",",2)," ",1)
         S SSN=$P(^DPT(DFN,0),U,9)
         S LSTFOUR=$E(SSN,6,9),ANQX=1
         D NUMBER1^PSOCLUTL
         Q:$G(ANQX)
         S MSG(1)=REG_","_LAST_","_FIRST_","_LSTFOUR
         S XMTEXT="MSG("
         D ^XMD
         X ^%ZOSF("UCI")
         I Y=^%ZOSF("PROD") S XMY("G.RUCLDEM@FO-DALLAS.MED.DNS   ")=""
         I Y'=^%ZOSF("PROD") S XMY("G.CLOZAPINE ROLL-UP")=""
         D ^XMD
         S DFN=TMP1
         I '$G(XMMG) S MSGNUM=$G(XMZ)
         E  W !!,"Failed to connect with the NCCC." S PSOFL=1 Q
         ; Now trick the server into thinking it is sending a message
         ; so we can populate 55, and 603.01
         S PSCLOZ=1
         S ^TMP("CLOZFLG")=1
         S XMRG=MSG(1)
         S XMFROM=DUZ
         D NOW^%DTC
         S XQDATE=%
         D ^YSCLSERV
         S ^XTMP("PSJ CLOZ",0)=DT+365_U_DT_U_"CLOZAPINE WEEKEND REGISTRATION"_U_
          REG
         S ^XTMP("PSJ CLOZ",DFN)=DT_U_REG_U_"A"
         S X1=%
         S X2=4
         D C^%DTC
         S ^XTMP("PSJ CLOZ","B",REG,DFN)=X
         S ^XTMP("PSJ CLOZ","C",DFN,REG)=""
         S ANQX=0
         S CLOZFLG=1
QUIT     Q
         ;
FINDNEXT() --
          ; Find the next pseudo Clozapine registration number
         N DATA,ERR,NUM,PAD,PREF,REG,SITE
         I '$D(^XTMP("PSJ CLOZ",0)) D
         . S ^XTMP("PSJ CLOZ",0)=DT+365_U_DT_U_"CLOZAPINE WEEKEND REGISTRATION"_
          U_0
         S PAD="00"
         S SITE=$P($$SITE^VASITE,"^",3)
         S REG=$P(^XTMP("PSJ CLOZ",0),U,4)
         S PAD="00"
         ; Get current temporary registration number
         I REG=0 D  Q REG
         . S REG="Z"_SITE_"001"
         ; Parse it into prefix, site and number
         S PREF=$P(REG,SITE,1)
         S NUM=+$P(REG,SITE,2)+1
         ; if the number part is >999 make the prefix the next lower (ascii) cha
          racter
         ; and the number part 001
         I NUM>999 D  Q REG
         . S NUM="001"
         . S $E(PREF,1)=$CHAR($A($E(PREF,1))-1)
         . S REG=PREF_SITE_NUM
         S NUM=$E(PAD,1,3-$L(+NUM))_+NUM
         S REG=PREF_SITE_NUM
         I $A(PREF)<65 S REG=-1
         Q REG
         ;
         ; /RBN End NCC weekend/new patient for PSO*7.0*457
OVRD2    ;
         S ANQX=0
         D PHGRP
         S DIC("S")="I $D(^XUSEC(""PSOLOCKCLOZ"",+Y)),+Y'=DUZ,$D(^TMP(""XQADUZ""
          ,$J,+Y))"
         S DIC=200,DIC(0)="AEQM",DIC("A")="Enter the name of an ""Approving memb
          er from the Clozapine team"": " D ^DIC D
         . I 'Y!($D(DUOUT))!(Y<0)!($D(DTOUT)) S ANQX=1 K DIC
         . S PSSPHARM=+Y
         Q
         ;
         ;/RBN Begin modifications for defect 689690 PSJ*5.0*457
OVRREA   ; Override reason when order is NCCC Approved
         S ANQX=0
         I $G(ANQRE)=7!($G(ANQRE)>8) D
         . K DIR,DTOUT,DUOUT,DIRUT,DIROUT
         . S DIR(0)="F^5:200"
         . S DIR("A")="Remarks"
         . S DIR("?")="Response is free test between 5 and 200 characters."
         . D ^DIR
         . I $G(DTOUT)!$G(DUOUT)!$G(DIRUT)!$G(DIROUT) S ANXQ=1 G EXIT
         . S PSREMARK=Y
         . K DIR,DTOUT,DUOUT,DIRUT,DIROUT
         .;/RBN End modifications for defect 689690 PSJ*5.0*457
         Q
         ;
CHK4REG(YSCLDFN) --
          ; See iF this patient already has a clozapine registration number
         N YSCLANS
         S YSCLANS=""
         S YSCLANS=$O(^XTMP("PSJ CLOZ","C",YSCLDFN,YSCLANS))
         Q YSCLANS
         ;
CHK4DFN(YSCLREG) --
          ; See if this Clozapine registration is assigned
         N YSCLANS
         S YSCLANS=$O(^XTMP("PSJ CLOZ","B",YSCLREG,""))
         Q YSCLANS
         ;
CHK4EXP(YSCLREG,YSCLDFN) --
          ; Check for registration expiration
         ;    RETURNS 0 IF EXPIRED
         ;            1 IF NOT EXPIRED
         N YSCLANS,YSCLDAT
         S YSCLANS=1
         I $D(^XTMP("PSJ CLOZ","B",YSCLREG,YSCLDFN)) D
         . S YSCLDAT=$G(^XTMP("PSJ CLOZ","B",YSCLREG,YSCLDFN))
         . I YSCLDAT<DT D
         . . S YSCLANS=0
         . . S:YSCLDAT>0 $P(^XTMP("PSJ CLOZ",YSCLDFN),U,3)="D"
         Q YSCLANS
         ;
         ; ** NCC REMEDIATION add new reasons 8-11 ** 457/RTW  11 ;;EMERGENCY OV
          ERRIDE NO ANC LAST 7 DAYS 
         ;
1        ;;NO WBC IN LAST 7 DAYS
2        ;;NO VERIFIED WBC
3        ;;LAST WBC RESULT < 3500
4        ;;3 SEQ. WBC DECREASE
5        ;;LAST ANC RESULT < 2000
6        ;;3 SEQ. ANC DECREASE
7        ;;NCCC AUTHORIZED
8        ;;REGISTER NON-DUTY HRS/WE (MAX 4D)
9        ;;PRESCRIBER APPROVED 4 DAY SUPPLY
10       ;;MILD NEUTROPENIA PRESCRIBER APPROVED

*****   INDEX OF PSOCLO1   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            PSOCLO1+9~,NOREG+2~,NOREG+10*,NOREG+12,CONT+32,CONT+36
   %DT          PSOCLO1+9~
   ANQ          PSOCLO1+9~
   ANQ(         CHECK+6*,CHECK+15
   ANQ(""       CHECK+7
   ANQ(1        CHECK+4*
   ANQD         PSOCLO1+9~,CHECK+3*,CHECK+6*,CHECK+7*,CHECK+9,CHECK+10,CHECK+12
                CHECK+15*
   ANQD(        CHECK+6*,CHECK+15
   ANQD(1       CHECK+3*
   ANQDATA      PSOCLO1+8!,OVRD+19!,OVRD+69*
   ANQJ         PSOCLO1+9~,CHECK+6*,CHECK+15*
   ANQNO        PSOCLO1+8!
   ANQRE        PSOCLO1+9~,PSOCLO1+33*,OV1*,OV1+5,CHECK+2*,OVRD+6,OVRD+7,OVRD+8
                OVRD+17,OVRD+20,OVRD+31,OVRD+44,OVRD+55,OVRD+69,OVRREA+2
   ANQX         PSOCLO1+8!,OV1*,CHECK+1*,CHECK+8*,OVRD+1,OVRD+4*,OVRD+12
                OVRD+14,OVRD+16,OVRD+17*,OVRD+21*,OVRD+22*,OVRD+23,OVRD+25
                OVRD+27,OVRD+29,OVRD+33,OVRD+35,OVRD+37*,OVRD+41,OVRD+43
                OVRD+46,OVRD+50,OVRD+52,OVRD+54,OVRD+57,OVRD+59,OVRD+61,OVRD+67
                OVRD+69*,EXIT+2*,EXIT+3,OVPRMPT*,QU*,NOREG+6*,NOREG+12*
                CONT+12*,CONT+14,CONT+41*,OVRD2+1*,OVRD2+5*,OVRREA+1*
>> ANXQ         OVRREA+8*
   CLOZFLG      PSOCLO1+8!,PSOCLO1+16*,PSOCLO1+17,PSOCLO1+19,PSOCLO1+31
                PSOCLO1+33,CONT+42*
>> CLOZPAT      PSOCLO1+29*,PSOCLO1+34,OV1+1
   DA           NOREG+22*,NOREG+24!
   DATA         FINDNEXT+1~
>> DFN          PSOCLO1+17,PSOCLO1+19,PSOCLO1+23,PSOCLO1+27,PSOCLO1+35,OV1
                OV1+2,OVRD+38,OVRD+47,OVRD+69,NOREG+14,NOREG+15,NOREG+18
                NOREG+20,NOREG+21,NOREG+22,CONT+3*,CONT+8,CONT+11,CONT+22*
                CONT+35,CONT+39,CONT+40
   DIC          OVRD2+4*,OVRD2+5!
   DIC("A"      OVRD2+4*
   DIC("S"      OVRD2+3*
   DIC(0        OVRD2+4*
   DIK          NOREG+23*,NOREG+24!
   DIR          PSOCLO1+9~,OVRD+17!,OVRD+22!,OVRD+36!,OVRD+37!,DOSE+1!,DOSE+4!
                DOSE+5!,OVPRMPT!,DIR+1!,OVRREA+3!,OVRREA+10!
   DIR("?"      OVRREA+6*
   DIR("A"      OVRD+17*,OVRD+22*,OVRD+37*,DOSE+1*,DOSE+4*,DOSE+5*,OVPRMPT*
                DIR+1*,OVRREA+5*
   DIR("B"      OVRD+17*,OVRD+22*,DOSE+4*,OVPRMPT*
   DIR(0        OVRD+17*,OVRD+22*,OVRD+36*,DOSE+1*,DOSE+4*,DOSE+5*,OVPRMPT*
                DIR+1*,OVRREA+4*
   DIROUT       OVRD+17,OVRD+22,OVPRMPT,OVRREA+3!,OVRREA+8,OVRREA+10!
   DIRUT        PSOCLO1+9~,OVRD+36!,OVRD+37,DOSE+1,DOSE+4,DOSE+5,EXIT+2,DIR+1!
                OVRREA+3!,OVRREA+8,OVRREA+10!
   DT           CONT+34,CONT+35,FINDNEXT+3,CHK4EXP+7
   DTOUT        PSOCLO1+9~,OVRD+17,OVRD+22,OVPRMPT,DIR+1!,OVRD2+5,OVRREA+3!
                OVRREA+8,OVRREA+10!
   DUOUT        PSOCLO1+9~,OVRD+17,DIR+1!,OVRD2+5,OVRREA+3!,OVRREA+8,OVRREA+10!
>> DUPRX0       OVRD+65
   DUZ          CHECK+1,OVRD+3,OVRD+69,PHGRP+4,NOREG+5,CONT+30
   ERR          FINDNEXT+1~
   FIRST        NOREG+2~,CONT+10*,CONT+15
   FLG          PSOCLO1+8!,NOREG+2~
   I            NOREG+2~
   J            PSOCLO1+9~
   LAST         NOREG+2~,CONT+9*,CONT+15
   LSTFOUR      PSOCLO1+9~,NOREG+2~,CONT+12*,CONT+15
   MSG          NOREG+2~
   MSG(1        CONT+15*,CONT+29
   MSGNUM       NOREG+2~,CONT+23*
   NAME         NOREG+2~,CONT+8*,CONT+9,CONT+10
>> ND0          OVRD+63
   NOW          NOREG+2~
   NUM          FINDNEXT+1~,FINDNEXT+13*,FINDNEXT+16,FINDNEXT+17*,FINDNEXT+19
                FINDNEXT+20*,FINDNEXT+21
>> ORO          OVRD+64
   PAD          FINDNEXT+1~,FINDNEXT+4*,FINDNEXT+7*,FINDNEXT+20
   PREF         FINDNEXT+1~,FINDNEXT+12*,FINDNEXT+18*,FINDNEXT+19,FINDNEXT+21
                FINDNEXT+22
>> PSCLOZ       CONT+2*,CONT+27*
>> PSCLPAT      OVRD+69*
>> PSJCNT       PHGRP+1*,PHGRP+5*,PHGRP+7
>> PSJORDER("PSJORN" 
                OVRD+63*,OVRD+64*
>> PSJORN       OVRD+63*,OVRD+64*
>> PSLAST7      PSOCLO1+26*,CHECK+2
   PSMSGTXT     PSOCLO1+11~,PSOCLO1+12*,PSOCLO1+13*,OVRD+19,OVRD+22,EXIT+3
                OVPRMPT
   PSO1         NOREG+2~,NOREG+14*,CONT+1
   PSO2         NOREG+2~,NOREG+20*,NOREG+25*,NOREG+26,CONT,CONT+4*,CONT+6
   PSO4         NOREG+2~
   PSOCD        GDOSE+1~,DOSE+2*,DOSE+3,DOSE+4,DOSE+5,EXIT+4
>> PSOFL        CONT+24*
   PSONAME      NOREG+2~,CONT+1*
>> PSONEW("SAND" 
                PSOCLO1+8!,EXIT+4*
   PSOYS        PSOCLO1+9~,PSOCLO1+27*,PSOCLO1+28,PSOCLO1+29,PSOCLO1+30
                PSOCLO1+31,PSOCLO1+32,PSOCLO1+33,OV1+6,OV1+8,OV1+9,OV1+10
                OV1+12,OV1+13,OV1+14,CHECK+2,CHECK+3,CHECK+4,CHECK+8,CHECK+12
                EXIT+4,DSP+2,DSP+6,DSP+7,DSP+8
>> PSPROVID     OVRD+62*,OVRD+63*,OVRD+64*,OVRD+65*,OVRD+69
   PSREASON     OVRD+2~,OVRD+10*,OVRD+38*,OVRD+39,OVRD+42,OVRD+47*,OVRD+48
                OVRD+53
   PSREG        PSOCLO1+9~,PSOCLO1+23*,CHECK+8
>> PSREMARK     OVRD+42*,OVRD+53*,OVRD+69,OVRREA+9*
>> PSSPHARM     OVRD+69,OVRD2+6*
   PSTYPE       PSOCLO1+9~,PSOCLO1+12*,PSOCLO1+13*,OV1+7,OV1+11,OVRD+31,OVRD+44
                GDOSE+2,NOREG+6
   REG          NOREG+2~,CONT+6*,CONT+15,CONT+34,CONT+35,CONT+39,CONT+40
                FINDNEXT+1~,FINDNEXT+6*,FINDNEXT+9,FINDNEXT+10*,FINDNEXT+12
                FINDNEXT+13,FINDNEXT+16,FINDNEXT+19*,FINDNEXT+21*,FINDNEXT+22*
                FINDNEXT+23
   SITE         FINDNEXT+1~,FINDNEXT+5*,FINDNEXT+10,FINDNEXT+12,FINDNEXT+13
                FINDNEXT+19,FINDNEXT+21
   SSN          NOREG+2~,CONT+11*,CONT+12
   STAT         NOREG+2~
   TMP1         NOREG+2~,NOREG+15*,CONT+3,CONT+22
   TMP2         NOREG+3~,CONT*,CONT+4
   U            NOREG+21,CONT+1,CONT+11,CONT+34,CONT+35,FINDNEXT+3,FINDNEXT+6
                CHK4EXP+9
   X            PSOCLO1+9~,PSOCLO1+34*,PSOCLO1+35,OV1+1*,OV1+2,DOSE+2,NOREG+3~
                CONT+39
   X1           NOREG+3~,CONT+36*
>> X2           CONT+37*
   X2XML        NOREG+3~
   XDUZ         PHGRP+1*,PHGRP+2,PHGRP+3,PHGRP+4,PHGRP+6,PHGRP+8!
>> XMFROM       CONT+30*
>> XMMG         CONT+23
>> XMRG         CONT+29*
   XMSUB        NOREG+3~,CONT+5*
   XMTEXT       NOREG+3~,CONT+16*
>> XMY("G.CLOZAPINE ROLL-UP" 
                CONT+20*
>> XMY("G.RUCLDEM@FO-DALLAS.MED.DNS   " 
                CONT+19*
>> XMZ          CONT+23
>> XQDATE       CONT+32*
>> XQY0         PSOCLO1+12,PSOCLO1+13
   Y            PSOCLO1+9~,OVRD+17,OVRD+22,DOSE+4,DOSE+5,OVPRMPT,DSP+6*,CONT+19
                CONT+20,OVRD2+5,OVRD2+6,OVRREA+9
   Y(0          OVRD+17,OVRD+38
   YSCLANS      CHK4REG+1~,CHK4REG+2*,CHK4REG+3*,CHK4REG+4,CHK4DFN+1~
                CHK4DFN+2*,CHK4DFN+3,CHK4EXP+3~,CHK4EXP+4*,CHK4EXP+8*
                CHK4EXP+10
   YSCLDAT      CHK4EXP+3~,CHK4EXP+6*,CHK4EXP+7,CHK4EXP+9
   YSCLDFN      CHK4REG~,CHK4REG+3,CHK4EXP~,CHK4EXP+5,CHK4EXP+6,CHK4EXP+9
   YSCLFRQ      NOREG+3~
   YSCLREG      CHK4DFN~,CHK4DFN+2,CHK4EXP~,CHK4EXP+5,CHK4EXP+6

Global Variables  ( * Changed  ! Killed)
   ^%ZOSF("PROD"       CONT+19,CONT+20
   ^%ZOSF("UCI"        CONT+18
   ^DD("DD"            DSP+6
   ^DPT(               CONT+1,CONT+8,CONT+11
   ^PS(55              PSOCLO1+17,PSOCLO1+19,PSOCLO1+23
   ^TMP("CLOZFLG"      PSOCLO1+23*,OVRD+38*,OVRD+47*,CONT+28*
   ^TMP("XQADUZ"       PHGRP+6*
   ^TMP($J             PSOCLO1+8!,PSOCLO1+36,CHECK+5,CHECK+6,EXIT+1!
   ^VA(200             PHGRP+2,PHGRP+3
   ^XTMP("PSJ CLOZ"    NOREG+21*,CONT+34*,CONT+35*,CONT+39*,CONT+40*,FINDNEXT+2
                       FINDNEXT+3*,FINDNEXT+6,CHK4REG+3,CHK4DFN+2,CHK4EXP+5
                       CHK4EXP+6,CHK4EXP+9*
   ^XUSEC("PSOLOCKCLOZ"OVRD+3,PHGRP+1,NOREG+5
   ^XUSEC("YSCL AUTHORIZED"
                       CHECK+1
   ^YSCL(603.01        NOREG+22

Naked Globals
   ^(           CHECK+6

Cache Objects
   NONE

Marked Items
   $T(@(3)      OVRD+6,OVRD+10

Label References
   $$CHK4REG    NOREG+18,NOREG+20
   $$FINDNEXT   NOREG+25
   CHECK        PSOCLO1+36,OV1+4
   CONT         NOREG+18
   DIR          QU
   DOSE         DOSE+4,DOSE+5
   DSP          PSOCLO1+32
   END          PSOCLO1+28,NOREG+26
   EXIT         OVRD+3,OVRD+16,OVRD+17,OVRD+29,OVRD+37,OVRD+43,OVRD+54,DOSE+1
                DOSE+3,DOSE+4,DOSE+5,OVRREA+8
   GDOSE        PSOCLO1+32
   MH           OV1+6
   NOREG        PSOCLO1+17,PSOCLO1+19
   OV1          PSOCLO1+30
   OVPRMPT      OVRD+11,OVRD+24,OVRD+32,OVRD+45,OVRD+56
   OVRD         PSOCLO1+36,OV1,OV1+5,OV1+8,OV1+9,OV1+12,OV1+13
   OVRD2        OVRD+13,OVRD+26,OVRD+34,OVRD+49,OVRD+58
   OVRREA       OVRD+15,OVRD+28,OVRD+40,OVRD+51,OVRD+60
   PHGRP        OVRD2+2

External References
   C^%DTC              CONT+38
   NOW^%DTC            CONT+31
   ^DIC                OVRD2+4
   YN^DICN             NOREG+11
   ^DIK                NOREG+23
   ^DIR                OVRD+17,OVRD+22,OVRD+37,DOSE+1,DOSE+4,DOSE+5,OVPRMPT
                       DIR+1,OVRREA+7
   MSG1^PSJCLOZ        OV1+10,OV1+14
   MSG10^PSJCLOZ       OV1+12,OV1+13
   MSG3^PSJCLOZ        OV1+6
   MSG4^PSJCLOZ        OV1+6
   MSG5^PSJCLOZ        END+1
   MSG6^PSJCLOZ        OVRD+18
   MSG9^PSJCLOZ        OV1+8,OV1+9
   NUMBER1^PSOCLUTL    CONT+13
   $$SITE^VASITE       FINDNEXT+5
   ^XMD                CONT+17,CONT+21
   ^YSCLSERV           CONT+33
   $$CL^YSCLTST2       PSOCLO1+27
   $$OVERRIDE^YSCLTST2 OV1
   CL1^YSCLTST2        PSOCLO1+35,OV1+2

*****   END   *****


PSOCLUTL * *  72 Lines,  5712 Bytes, Checksum: B30238354
                                                  Jul 01, 2016@06:56:32 page 3
              1503 bytes in comments
PSOCLUTL ;BHAM ISC/DMA - utilities for clozapine reporting system ; 12/22/92
         ;;7.0;OUTPATIENT PHARMACY;**28,56,122,222,268,457**;DEC 1997;Build 10
         ;External reference ^YSCL(603.01 supported by DBIA 2697
         ;External reference ^PS(55 supported by DBIA 2228
         ;
REG      ; register patient
         S DIC=55,DLAYGO=55,DIC(0)="AEQL",DIC("A")="Select patient to register: 
          " D ^DIC K DIC G END:Y<0 S PSO1=+Y,PSONAME=$P(^DPT(PSO1,0),"^") K DLAY
          GO
         D:$P($G(^PS(55,PSO1,0)),"^",6)'=2 EN^PSOHLUP(PSO1)
         I '$D(^YSCL(603.01,"C",PSO1)) W !!,PSONAME_" has not been authorized fo
          r Clozapine",!,"by the NCCC in Dallas.  Contact the NCCC in Dallas for
           authorization." D OVER G:'$G(%) REG S JADOVER=""
         I $P($G(^PS(55,PSO1,"SAND")),"^")]"" S PSO4=^("SAND") W !!,PSONAME_" is
           already registered with number "_$P(PSO4,"^"),!!,"Use the edit option
           to change registration data, or",!,"contact your supervisor",! G REG
NUMBER   S DIR(0)="55,53" D ^DIR S PSO2=Y K DIR I $D(DIRUT) W !,"Not registered"
          ,! D END G REG
         I $D(^PS(55,"ASAND1",PSO2)),$O(^(PSO2,0))'=PSO1 W !,PSO2," is already a
          ssigned to ",$P(^DPT(+$O(^(0)),0),"^") W !,"Please contact your superv
          isor" D END G REG
         ;/RBN Begin NCC changes to remove Pretreatment choice - PSO*7.0*457
         ;S DIR("A")="Pre-treatment or Active treatment? ",DIR(0)="S^P:PRE-TREAT
          MENT;A:ACTIVE TREATMENT;",DIR("?")="Is this patient new to the Clozapi
          ne program, or has s/he been receiving treatment?" D ^DIR K DIR S PSO3
          =Y
         ;I $D(DIRUT) W !!,"Not registered" R X:10 K X G END
NUMBER1  S PSO3="A"
         ;/RBN End NCC changes to remove Pretreatment choice - PSO*7.0*457
         ;I $D(DIRUT) W !!,"Not registered" R X:10 K X G END
PHY      S DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")="Provider responsible: ",DIC("
          S")="I $G(^VA(200,+Y,""PS""))]""""" D ^DIC K DIC I Y<0 W !!,"Not regis
          tered",!! K X G END1
         I $G(PSCLOZ) D PROVCHK^PSJCLOZ(+Y) G:(ANQX) PHY
         ;I $P($G(^VA(200,+Y,"PS")),"^",2)']"" W !!,"Only providers with DEA num
          bers entered in the New Person",!,"file can register patients in this 
          program.",!! G PHY
         S PSO4=+Y K DIR,DIRUT,DUOUT,DTOUT
         ;/RBN Begin NCC changes Ask if okay to register the unregistered patien
          t - PSO*7.0*457
         S SSN=$P(^DPT(PSO1,0),U,9)
         S LSTFOUR=$E(SSN,6,9)
         I '$G(CLOZ) D  G:$G(ANQX) END1
         . S DIR("A",1)="Would you like to override the registration requirement
           and assign a temporary"
         . S DIR("A",2)="local authorization number for  "_PSONAME_" ("_$G(LSTFO
          UR)_")"_" with number "_PSO2,DIR("A")="as a"_$S('PSO3:" new",1:"n ongo
          ing")_" patient in this program "
         I $G(CLOZ) D  G:$G(ANQX) END1
         . S DIR("A",1)="Would you like to override the registration requirement
           and assign a temporary"
         . S DIR("A",2)="local authorization number for  "_PSONAME_" ("_$G(LSTFO
          UR)_")"_" with number "_PSO2
         S DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR I Y=0!($D(DUOUT)) S ANQX=1
         G:$G(ANQX) END1
         ;/RBN End NCC changes to remove Pretreatment choice - PSO*7.0*457
SAVE     S DA=PSO1,DIE=55,DR="53////"_PSO2_";54////"_PSO3_";57////"_PSO4_";56///
          /0;58////"_DT
         L +^PS(55,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !
          !,$C(7),"Patient "_PSONAME_" is being edited by another user!  Try Lat
          er." S ANQX=1 G END1
         D ^DIE L -^PS(55,DA)
END      K %,%Y,C,D,D0,DA,DI,DQ,DIC,DIE,DR,PSO,PSO1,PSO2,PSO3,PSO4,PSOC,PSOLN,PS
          ONAME,PSONO,PSOT,R,SSNVAERR,XMDUZ,XMSUB,XMTEXT,Y,^TMP($J),^TMP("PSO",$
          J) Q
         Q
END1     ;
         I $G(ANQX) W !!,"Patient Not Registered"
         Q
         ;
FACILITY ;Enter facility DEA number to set up clozapine system
         ;this entry point is no longer used.  this functionality was taken over
         ;by the mental health package with the release of YS*5.01*18
         ;W ! S DIC=59,DIC(0)="AEQM",DIC("A")="Select site to participate in clo
          zapine program : " D ^DIC G END:Y<0
         ;S DIE=DIC,DA=+Y,DR="1R;2R;" L +^PS(59,DA) D ^DIE L -^PS(59,DA) G FACIL
          ITY
         Q
         ;
         ;
AGAIN    ; re-enter patient - new number, status and provider
         S DIC=55,DIC(0)="AEQM",DIC("A")="Select clozapine patient : " D ^DIC K 
          DIC G END:Y<0 S DA=+Y,PSO1=DA,PSONAME=$P(^DPT(DA,0),"^")
         I $P($G(^PS(55,DA,"SAND")),"^")="" W !,PSONAME_" is not registered.  Us
          e the register option." G AGAIN
         I '$D(^YSCL(603.01,"C",PSO1)) W !!,PSONAME_" has not been authorized fo
          r Clozapine",!,"by the NCCC in Dallas.  Contact the NCCC in Dallas for
           authorization." D OVER G:'$G(%) AGAIN S JADOVER=""
         S DIR(0)="55,53" D ^DIR G END:$D(DIRUT) S PSO2=Y I $D(^PS(55,"ASAND1",P
          SO2)),$O(^(PSO2,0))'=PSO1 W !,PSO2," already assigned to ",$P(^DPT($O(
          ^(0)),0),"^") G END
         I '$D(JADOVER),'$D(^YSCL(603.01,"B",PSO2)) W !!,"The NCCC in Dallas has
           not authorized "_PSO2_" for usage",!,"at this facility.  Contact the 
          NCCC in Dallas for authorization." D OVER G:'$G(%) END
         ;S DIR(0)="55,54" D ^DIR G END:$D(DIRUT) S PSO3=Y
         S PSO3=$P(^PS(55,DA,"SAND"),"^",2)
         W !,$P(^DD(55,54,0),"^")_": "_$S(PSO3="A":"ACTIVE TREATMENT",PSO3="D":"
          DISCONTINUED",PSO3="H":"TREATMENT ON HOLD",1:"PRE-TREATMENT")
PHY1     ;
         S PSO4=$P(^PS(55,DA,"SAND"),"^",5),DIR(0)="55,57" D ^DIR G END:$D(DIRUT
          ) I Y S PSO4=+Y
         I $P($G(^VA(200,PSO4,"PS")),"^",2)="" W !!,"Only providers with DEA num
          bers entered in the New Person",!,"file can register patients in this 
          program.",!! G PHY1
         G SAVE
         ;
OVER     ;allow registration of patients and clozapine numbers not yet authorize
          d by the NCCC.
         K DIR W ! S DIR("A")="Do you want to over-ride this warning",DIR(0)="Y"
          ,DIR("B")="No" D ^DIR
         I Y D  S %=1
         .Q  S YSCLDATA(1)="An over-ride was authorize at "_$G(DUZ(2))_" for "_$
          S($D(PSONAME):PSONAME,1:$G(PSO2))_" by "_$P($G(^VA(200,DUZ,0)),"^")
         .S %H=$H D YMD^%DTC S XMDUN="NCC LOGGER",XMDUZ=.5,XMSUB=$G(DUZ(2))_" NC
          C ENROLLER ("_X_%_")",XMTEXT="YSCLDATA(",XMY("G.CLOZAPINE ROLL-UP@FORU
          M.DNS   ")=""
         .D ^XMD K XMDUN,XMDUZ,XMER,XMREC,XRG,XMSUB,XMTEXT,XMY,XMZ,YSCLDATA
         K DIR,DIRUT,DUOUT Q

*****   INDEX OF PSOCLUTL   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            REG+3,END!,AGAIN+3,AGAIN+5,OVER+2*,OVER+4
>> %H           OVER+4*
   %Y           END!
>> ANQX         PHY+1,PHY+7,PHY+10,PHY+13*,PHY+14,SAVE+1*,END1+1
   C            END!
>> CLOZ         PHY+7,PHY+10
   D            END!
   D0           END!
   DA           SAVE*,SAVE+1,SAVE+2,END!,AGAIN+1*,AGAIN+2,AGAIN+7,PHY1+1
   DI           END!
   DIC          REG+1*!,PHY*!,END!,AGAIN+1*!
   DIC("A"      REG+1*,PHY*,AGAIN+1*
   DIC("S"      PHY*
   DIC(0        REG+1*,PHY*,AGAIN+1*
   DIE          SAVE*,END!
   DIR          NUMBER!,PHY+3!,PHY+13!,OVER+1!,OVER+6!
   DIR("A"      PHY+8*,PHY+9*,PHY+11*,PHY+12*,OVER+1*
   DIR("B"      PHY+13*,OVER+1*
   DIR(0        NUMBER*,PHY+13*,AGAIN+4*,PHY1+1*,OVER+1*
   DIRUT        NUMBER,PHY+3!,AGAIN+4,PHY1+1,OVER+6!
   DLAYGO       REG+1*!
   DQ           END!
   DR           SAVE*,END!
   DT           SAVE
   DTOUT        PHY+3!
   DUOUT        PHY+3!,PHY+13,OVER+6!
   DUZ          OVER+3
   DUZ(2        OVER+3,OVER+4
>> JADOVER      REG+3*,AGAIN+3*,AGAIN+5
>> LSTFOUR      PHY+6*,PHY+9,PHY+12
>> PSCLOZ       PHY+1
   PSO          END!
   PSO1         REG+1*,REG+2,REG+3,REG+4,NUMBER+1,PHY+5,SAVE,END!,AGAIN+1*
                AGAIN+3,AGAIN+4
   PSO2         NUMBER*,NUMBER+1,PHY+9,PHY+12,SAVE,END!,AGAIN+4*,AGAIN+5,OVER+3
   PSO3         NUMBER1*,PHY+9,SAVE,END!,AGAIN+7*,AGAIN+8
   PSO4         REG+4*,PHY+3*,SAVE,END!,PHY1+1*,PHY1+2
   PSOC         END!
   PSOLN        END!
   PSONAME      REG+1*,REG+3,REG+4,PHY+9,PHY+12,SAVE+1,END!,AGAIN+1*,AGAIN+2
                AGAIN+3,OVER+3
   PSONO        END!
   PSOT         END!
   R            END!
>> SSN          PHY+5*,PHY+6
   SSNVAERR     END!
   U            PHY+5
   X            PHY!,OVER+4
   XMDUN        OVER+4*,OVER+5!
   XMDUZ        END!,OVER+4*,OVER+5!
   XMER         OVER+5!
   XMREC        OVER+5!
   XMSUB        END!,OVER+4*,OVER+5!
   XMTEXT       END!,OVER+4*,OVER+5!
   XMY          OVER+5!
   XMY("G.CLOZAPINE ROLL-UP@FORUM.DNS   " 
                OVER+4*
   XMZ          OVER+5!
   XRG          OVER+5!
   Y            REG+1,NUMBER,PHY,PHY+1,PHY+3,PHY+13,END!,AGAIN+1,AGAIN+4,PHY1+1
                OVER+2
   YSCLDATA     OVER+5!
   YSCLDATA(1   OVER+3*

Global Variables  ( * Changed  ! Killed)
   ^DD("DILOCKTM"      SAVE+1
   ^DD(55              AGAIN+8
   ^DPT(               REG+1,NUMBER+1,PHY+5,AGAIN+1,AGAIN+4
   ^PS(55              REG+2,REG+4,NUMBER+1,SAVE+1,SAVE+2,AGAIN+2,AGAIN+4
                       AGAIN+7,PHY1+1
   ^TMP("PSO"          END!
   ^TMP($J             END!
   ^VA(200             PHY1+2,OVER+3
   ^YSCL(603.01        REG+3,AGAIN+3,AGAIN+5

Naked Globals
   ^(           NUMBER+1,AGAIN+4
   ^("SAND"     REG+4
   ^(0          NUMBER+1,AGAIN+4

Cache Objects
   NONE

Marked Items
   NONE

Label References
   AGAIN        AGAIN+2,AGAIN+3
   END          REG+1,NUMBER,NUMBER+1,AGAIN+1,AGAIN+4,AGAIN+5,PHY1+1
   END1         PHY,PHY+7,PHY+10,PHY+14,SAVE+1
   OVER         REG+3,AGAIN+3,AGAIN+5
   PHY          PHY+1
   PHY1         PHY1+2
   REG          REG+3,REG+4,NUMBER,NUMBER+1
   SAVE         PHY1+3

External References
   YMD^%DTC            OVER+4
   ^DIC                REG+1,PHY,AGAIN+1
   ^DIE                SAVE+2
   ^DIR                NUMBER,PHY+13,AGAIN+4,PHY1+1,OVER+1
   PROVCHK^PSJCLOZ     PHY+1
   EN^PSOHLUP          REG+2
   ^XMD                OVER+5

*****   END   *****


PSODRG   * *  230 Lines,  11202 Bytes, Checksum: B94156062
                                                  Jul 01, 2016@06:56:32 page 4
              1198 bytes in comments
PSODRG   ;IHS/DSD/JCM - ORDER ENTRY DRUG SELECTION ;2/16/12 12:50pm
         ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,3
          24,251,375,387,398,390,427,411,457**;DEC 1997;Build 10
         ;Reference to ^PSDRUG( supported by DBIA 221
         ;Reference to ^PS(50.7 supported by DBIA 2223
         ;Reference to $$PROMPT^PSSDIN supported by DBIA 3166
         ;Reference to EN^PSSDIN supported by DBIA 3166
         ;Reference to $$GETNDC^PSSNDCUT supported by DBIA 4707
         ;Reference to ^OROCAPI controlled subscription supported by DBIA 5367
         ;Reference to $$OITM^ORX8 supported by DBIA 5469
         ;Reference to ^VADPT supported by DBIA 10061
         ;Reference to IN^PSSHRQ2 supported by DBIA 5369
         ;Reference to ^XTMP("ORRDI" supported by DBIA 5440
         ;----------------------------------------------------------
START    ;
         S (PSONEW("DFLG"),PSONEW("FIELD"),PSODRG("QFLG"))=0 K PSORX("DFLG")
         D @($S(+$G(PSOEDIT)=1&('$D(DA)):"SELECT^PSODRGN",1:"SELECT"))
         G:$G(PSORXED("DFLG")) END ; Select Drug
         I $G(PSORX("EDIT")),$G(PSOY),$G(PSODRUG("IEN"))=+PSOY D  G:$G(PSORXED("
          DFLG")) END
         . N NDC D NDC(+$G(PSORXED("IRXN")),0,+PSOY,.NDC) I $G(NDC)="^" S PSORXE
          D("DFLG")=1 Q
         . I $G(NDC)'="" S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
         ;
         I $G(PSORX("EDIT"))]"",'PSONEW("FIELD") D TRADE
         G:$G(PSONEW("DFLG"))!($G(PSODRG("QFLG")))!($G(PSORXED("DFLG"))) END
         D SET ; Set various drug information
         D NFI ; Display dispense drug/orderable item text
         D:'$G(PSOEDIT) POST I $G(PSORX("DFLG")) S PSONEW("DFLG")=1 K:'$G(PSORX(
          "EDIT")) PSORX("DFLG") ; Do any post selection action
END      ;D EOJ
         Q
         ;------------------------------------------------------------
         ;
SELECT   ;
         K:'$G(PSORXED) CLOZPAT
         K IT,DIC,X,Y,PSODRUG("TRADE NAME"),PSODRUG("NDC"),PSODRUG("DAW"),PSODRU
          G("BAD") S:$G(POERR)&($P($G(OR0),"^",9)) Y=$P(^PSDRUG($P(OR0,"^",9),0)
          ,"^")
         I $G(PSODRUG("IEN"))]"" S Y=PSODRUG("NAME"),PSONEW("OLD VAL")=PSODRUG("
          IEN")
         W !,"DRUG: "_$S($G(Y)]"":Y_"// ",1:"") R X:$S($D(DTIME):DTIME,1:300) I 
          '$T S DTOUT=1
         I X="",$G(Y)]"" S:Y X=Y S:'X X=$G(PSODRUG("IEN")) S:X X="`"_X
         G:X="" SELECT
         I X?1."?" W !!,"Answer with DRUG NUMBER, or GENERIC NAME, or VA PRODUCT
           NAME, or",!,"NATIONAL DRUG CLASS, or SYNONYM" G SELECT
         I $G(PSORXED),X["^" S PSORXED("DFLG")=1 G SELECTX
         I X="^"!(X["^^")!($D(DTOUT)) S PSONEW("DFLG")=1 G SELECTX
         I '$G(POERR),X[U,$L(X)>1 S PSODIR("FLD")=PSONEW("FLD") D JUMP^PSODIR1 S
          :$G(PSODIR("FIELD")) PSONEW("FIELD")=PSODIR("FIELD") K PSODIR S PSODRG
          ("QFLG")=1 G SELECTX
         S DIC=50,DIC(0)="EMQZVT",DIC("T")="",D="B^C^VAPN^VAC"
         S DIC("S")="I $S('$D(^PSDRUG(+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:
          0),$S($P($G(^PSDRUG(+Y,2)),""^"",3)'[""O"":0,1:1),$D(^PSDRUG(""ASP"",+
          $G(^(2)),+Y))"
         D MIX^DIC1 K DIC,D
         I $D(DTOUT) S PSONEW("DFLG")=1 G SELECTX
         I $D(DUOUT) K DUOUT G SELECT
         I Y<0 G SELECT
         S:$G(PSONEW("OLD VAL"))=+Y&('$G(PSOEDIT)) PSODRG("QFLG")=1
         K PSOY S PSOY=Y,PSOY(0)=Y(0)
         I $P(PSOY(0),"^")="OTHER DRUG"!($P(PSOY(0),"^")="OUTSIDE DRUG") D TRADE
SELECTX  K X,Y,DTOUT,DUOUT,PSONEW("OLD VAL")
         Q
         ;
NDC(RX,RFL,DRG,NDC) --
          ; Editing NDC for Released Rx's or for Unresolved ECME Rejects
         S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
         ; Check if we should edit the NDC
         ; Needs to be released or have unresolved billable rejects (PSO*7*427)
         ;
         N PSOCONT S PSOCONT=0                         ; continue flag
         D  Q:'PSOCONT                                 ; get out if NDC edit not
           allowed
         . I $$RXRLDT^PSOBPSUT(RX,RFL) S PSOCONT=1 Q   ; Released - continue and
           allow edit
         . I $$FIND^PSOREJUT(RX,RFL),$$STATUS^PSOBPSUT(RX,RFL)'="" S PSOCONT=1 Q
             ; unreleased w/unresolved billable rejections
         . Q
         ;
         S NDC=$S($G(NDC)'="":$G(NDC),1:$$GETNDC^PSONDCUT(RX,.RFL))
         D NDCEDT^PSONDCUT(RX,.RFL,$G(DRG),$G(PSOSITE),.NDC)
         Q
         ;
TRADE    ;
         K DIR,DIC,DA,X,Y
         S DIR(0)="52,6.5" S:$G(PSOTRN)]"" DIR("B")=$G(PSOTRN) D ^DIR K DIR,DIC
         I X="@" S Y=X K DIRUT
         I $D(DIRUT) S:$D(DUOUT)!$D(DTOUT)&('$D(PSORX("EDIT"))) PSONEW("DFLG")=1
           G TRADEX
         S PSODRUG("TRADE NAME")=Y
TRADEX   I $G(PSORXED("DFLG")),$D(DIRUT) S PSORXED("DFLG")=1
         K DIRUT,DTOUT,DUOUT,X,Y,DA,DR,DIE
         Q
SET      ;
         N STAT S PSODRUG("IEN")=+PSOY,PSODRUG("VA CLASS")=$P(PSOY(0),"^",2)
         S PSODRUG("NAME")=$P(PSOY(0),"^")
         S:+$G(^PSDRUG(+PSOY,2)) PSODRUG("OI")=+$G(^(2)),PSODRUG("OIN")=$P(^PS(5
          0.7,+$G(^(2)),0),"^")
         S PSODRUG("NDF")=$S($G(^PSDRUG(+PSOY,"ND"))]"":+^("ND")_"A"_$P(^("ND"),
          "^",3),1:0)
         S PSODRUG("MAXDOSE")=$P(PSOY(0),"^",4),PSODRUG("DEA")=$P(PSOY(0),"^",3)
         S PSODRUG("CLN")=$S($D(^PSDRUG(+PSOY,"ND")):+$P(^("ND"),"^",6),1:0)
         S PSODRUG("SIG")=$P(PSOY(0),"^",5)
         I $G(PSODRUG("NDC"))="" S PSODRUG("NDC")=$$GETNDC^PSSNDCUT(+PSOY,$G(PSO
          SITE))
         S PSODRUG("DAW")=+$$GET1^DIQ(50,+PSOY,81)
         S PSODRUG("STKLVL")=$G(^PSDRUG(+PSOY,660.1))
         G:$G(^PSDRUG(+PSOY,660))']"" SETX
         S PSOX1=$G(^PSDRUG(+PSOY,660))
         S PSODRUG("COST")=$P($G(PSOX1),"^",6)
         S PSODRUG("UNIT")=$P($G(PSOX1),"^",8)
         S PSODRUG("EXPIRATION DATE")=$P($G(PSOX1),"^",9)
SETX     K PSOX1,PSOY
         Q
NFI      ;display restriction/guidelines
         D EN^PSSDIN(PSODRUG("OI"),PSODRUG("IEN")) S NFI=$$PROMPT^PSSDIN
         I NFI]"","ODY"[NFI D TD^PSONFI
         K NFI Q
POST     ;order checks
         N LIST S LIST="PSOPEPS"
         K PSODOSD,^TMP("PSORXDC",$J),^TMP($J,LIST),^TMP("PSODAOC",$J)
         K ZDGDG,ZTHER,IT,PSODLQT,PSODOSD
         I $D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) S ^TMP("PSODAOC",$J,"NORDI",1
          ,0)="Remote data not available - Only local order checks processed."
         S ^TMP($J,LIST,"IN","PING")="" D IN^PSSHRQ2(LIST)
         K DIR I $P(^TMP($J,LIST,"OUT",0),"^")=-1 D
         .D DATACK^PSODDPRE
         .S ^TMP("PSODAOC",$J,"NOSYS",1,0)="No Enhanced Order Checks can be perf
          ormed. Reason(s): "_$P($G(^TMP($J,LIST,"OUT",0)),"^",2)
         K ^TMP($J,LIST,"IN"),^TMP($J,LIST,"OUT","EXCEPTIONS")
         G:$G(PSORX("DFLG"))!($G(PSORXED("DFLG"))) POSTX
         K PSORX("INTERVENE"),PSOQUIT N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
         W !! D HD^PSODDPR2():(($Y+5)'>IOSL)
         D ^PSOBUILD
         D:'$D(PSODGCK) @$S($G(COPY):"^PSOCPPRE",1:"^PSODDPRE") ; Duplicate drug
           check
         G:$G(PSORX("DFLG")) POSTX
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         I $P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")="PSOCLO1" W !,"Now doing 
          Clozapine Order checks.  Please wait...",! D CLOZ
         G:PSORX("DFLG") POSTX
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         W !,"Now doing allergy checks.  Please wait...",! H 1
         S PSONOAL="" D ALLERGY^PSOORUT2 D:PSONOAL'="" NOALRGY K PSONOAL
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         I '$G(PSODGCKX) D ^PSODGAL1 K PSORX("INTERVENE")
         G:PSORX("DFLG")!$G(PSOQUIT) POSTX
         ;This is the allergy check for profile drugs CK action
         I $D(PSODGCK),$D(PSOSD) D PRFLP^PSOUTL
         G:$G(PSORX("DFLG")) POSTX ;pso*7*412
         G:$G(PSOSPRNW)&($G(PSORENW("DFLG"))) POSTX ;speed renew
         ;aminoglycoside
         N AOC,CROCPFLG S CROCPFLG=0
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         S AOC=$$AOC^OROCAPI(PSODFN,$P(PSODRUG("NDF"),"A",2)) I $P(AOC,"^",4)]""
           D
         .S CROCPFLG=1
         .W !!,"***Aminoglycoside Ordered***",!!
         .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(AOC,"^",4) D ^DIWP
         .W ! F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX  W ?2,^UTILITY($J,"W
          ",1,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
         .K ^UTILITY($J,"W")
         .S ^TMP("PSODAOC",$J,"CPRS",$P(AOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(AOC,
          "^",4)
         .W !
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         ;dangerous meds for pat >64
         I $G(PSODRUG("OI")) D
         .N OI,OIR S OI=$$OITM^ORX8(PSODRUG("OI"),"99PSP") Q:'OI
         .S OIR=$$DOC^OROCAPI(PSODFN,OI) I $P(OIR,"^",4)]"" D
         ..S CROCPFLG=1
         ..D HD^PSODDPR2():(($Y+5)'>IOSL) W !!,"***Dangerous Meds for Patient >6
          4***",!! S DFN=PSODFN D DEM^VADPT
         ..K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(OIR,"^",4) D ^DIWP
         ..F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX  W ?2,^UTILITY($J,"W",1
          ,ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
         ..K ^UTILITY($J,"W")
         ..S ^TMP("PSODAOC",$J,"CPRS",$P(OIR,"^",2),0)=PSODRUG("IEN")_"^"_$P(OIR
          ,"^",4)
         ..W !
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         ;metformin lab results
         N GOC S GOC=$$GOC^OROCAPI(PSODFN,PSODRUG("NAME")) I $P(GOC,"^",4)]"" D
         .S CROCPFLG=1
         .W !!,"***Metformin Lab Results***",!!
         .K ^UTILITY($J,"W") S DIWL=1,DIWR=78,DIWF="" S X=$P(GOC,"^",4) D ^DIWP
         .F ZX=0:0 S ZX=$O(^UTILITY($J,"W",1,ZX)) Q:'ZX  W ?2,^UTILITY($J,"W",1,
          ZX,0),! D HD^PSODDPR2():(($Y+5)'>IOSL)
         .K ^UTILITY($J,"W")
         .S ^TMP("PSODAOC",$J,"CPRS",$P(GOC,"^",2),0)=PSODRUG("IEN")_"^"_$P(GOC,
          "^",4)
         .W !
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         ;clinical reminder oc
         D:'$G(PSONCROC) CK^PSOCROC K CROCPFLG I $G(PSORX("DFLG")) Q
         K DIWF,DIWL,DIWR,ZX,DFN,CROCPFLG
         I $G(PSODRUG("DEA"))["S"!($E($G(PSODRUG("VA CLASS")),1,2)="XA") D  G PO
          STX ;stops if drug is supply
         .W !,"Now Processing Enhanced Order Checks!  Please wait...",! H 1
         ;enhanced OC
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         ;/RBN - BEGIN MODIFICATIONS FOR PSO*7*457
         I '$D(CLOZFLG) W ! D @$S($G(COPY):"OBX^PSOCPPRE",1:"OBX^PSODDPRE") ; Se
          t PSORX("DFLG")=1 if process to stop new enhanced order checks
         ;/RBN - END MODIFICATIONS FOR PSO*7*457
POSTX    ;
         K IT,^TMP($J,"DI"),PSORX("INTERVENE"),DA,^TMP($J,"PSODRDI"),ZDGDG,ZTHER
          ,^TMP($J,"DI"_PSODFN),PSZZQUIT
         I '$G(PSORXED),'$G(PSOREINS) K PSOQUIT
         Q
         ;
EO       ;
         K PSODRG
         Q
WAIT     ;
         K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press 
          Return to continue..." W !
         D ^DIR K DIRUT,DUOUT,DIR,X,Y
         Q
         ;
CLOZ     ;
         S ANQRTN=$P(^PSDRUG(PSODRUG("IEN"),"CLOZ1"),"^"),ANQX=0
         S P(5)=PSODRUG("IEN"),DFN=PSODFN,X=ANQRTN
         X ^%ZOSF("TEST") I  D @("^"_ANQRTN) S:$G(ANQX) PSORX("DFLG")=1
         K P(5),ANQRTN,ANQX,X,DFN
         Q
         ;
EN(DRG)  ;returns lab test identified for clozapine order checking
         K LAB I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")'="PSOCLO1" S LAB("NOT")=0 Q
         I $P($G(^PSDRUG(DRG,"CLOZ1")),"^")="PSOCLO1" D
         .S (CNT,I)=0 F  S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  S CNT=$G(CNT)+1
         .I CNT'=2 S LAB("BAD TEST")=0 K CNT Q
         .K CNT F I=0:0 S I=$O(^PSDRUG(DRG,"CLOZ2",I)) Q:'I  D
         ..S LABT=$S($P(^PSDRUG(DRG,"CLOZ2",I,0),"^",4)=1:"WBC",1:"ANC"),LAB(LAB
          T)=$P(^PSDRUG(DRG,"CLOZ2",I,0),"^")_"^"_$P(^(0),"^",3)_"^"_$P(^(0),"^"
          ,4)
         K LABT,I
         Q
NOALRGY  ;
         D HD^PSODDPR2():(($Y+5)'>IOSL)
         N DIR S DIR(0)="SA^1:YES;0:NO"
         I $D(^TMP($J,"PSOINTERVENE",+PSODFN)) D  Q
         .S DIR("A")="No Allergy Assessment - Do you want to duplicate Intervent
          ion?: ",DIR("B")="Yes"
         .D ^DIR
         .I 'Y D  Q
         ..I Y=0 D ^PSORXI Q
         ..S PSORX("DFLG")=1
         .D DUPINV^PSORXI
         W $C(7),!,"There is no allergy assessment on file for this patient."
         W !,"You will be prompted to intervene if you continue with this prescr
          iption"
         I $D(PSODGCK) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue
          ..." D ^DIR K DIR
         Q:$D(PSODGCK)
         N DUOUT,DTOUT,RXIEN,RXSTA               ;*398
         S DIR("A")="Do you want to Continue?: ",DIR("B")="N" D ^DIR
         I 'Y!($D(DUOUT))!($D(DTOUT)) D  Q       ;*398 - Exit/Timeout
         .I $D(PSONV) S PSZZQUIT=1 Q
         .S PSORX("DFLG")=1
         .I '$O(PSCAN(0)) Q                      ;*398 - Array has Rx IEN
         .I $G(REA)'="R" Q                       ;*398 - Reinstate only
         .S RXIEN=+$G(PSCAN(RX)) I 'RXIEN Q      ;*398 - Get Rx IEN
         .S RXSTA=$$GET1^DIQ(52,RXIEN,100,"I")   ;*398 - Get status
         .I RXSTA=12 Q                           ;*398 - Correct status
         .S DIE="^PSRX(",DA=RXIEN,DR="100///12"  ;*398 - Discontinued
         .D ^DIE                                 ;*398 - Update Rx file
         I $D(PSONV) S PSORX("INTERVENE")=0 D EN1^PSORXI(PSONV) Q
         D ^PSORXI
         Q

*****   INDEX OF PSODRG   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   ANQRTN       CLOZ+1*,CLOZ+2,CLOZ+3,CLOZ+4!
   ANQX         CLOZ+1*,CLOZ+3,CLOZ+4!
   AOC          POST+30~,POST+32*,POST+35,POST+38
>> CLOZFLG      POST+71
   CLOZPAT      SELECT+1!
   CNT          EN+3*,EN+4!,EN+5!
>> COPY         POST+14,POST+71
   CROCPFLG     POST+30~*,POST+33*,POST+45*,POST+55*,POST+64!,POST+65!
   D            SELECT+11*,SELECT+13!
   DA           START+2,TRADE+1!,TRADEX+1!,POSTX+1!,NOALRGY+24*
   DFN          POST+46*,POST+65!,CLOZ+2*,CLOZ+4!
   DIC          SELECT+2!,SELECT+11*,SELECT+13!,TRADE+1!,TRADE+2!
   DIC("S"      SELECT+12*
   DIC("T"      SELECT+11*
   DIC(0        SELECT+11*
   DIE          TRADEX+1!,NOALRGY+24*
   DIR          TRADE+1!,TRADE+2!,POST+6!,WAIT+1!,WAIT+2!,NOALRGY+2~
                NOALRGY+12!
   DIR("?"      WAIT+1*
   DIR("A"      WAIT+1*,NOALRGY+4*,NOALRGY+12*,NOALRGY+15*
   DIR("B"      TRADE+2*,NOALRGY+4*,NOALRGY+15*
   DIR(0        TRADE+2*,WAIT+1*,NOALRGY+2*,NOALRGY+12*
   DIRUT        TRADE+3!,TRADE+4,TRADEX,TRADEX+1!,WAIT+2!
   DIWF         POST+35*,POST+47*,POST+57*,POST+65!
   DIWL         POST+35*,POST+47*,POST+57*,POST+65!
   DIWR         POST+35*,POST+47*,POST+57*,POST+65!
   DR           TRADEX+1!,NOALRGY+24*
   DRG          NDC~,NDC+12,EN~,EN+1,EN+2,EN+3,EN+5,EN+6
   DTIME        SELECT+4
   DTOUT        SELECT+4*,SELECT+9,SELECT+14,SELECTX!,TRADE+4,TRADEX+1!
                NOALRGY+14~,NOALRGY+16
   DUOUT        SELECT+15!,SELECTX!,TRADE+4,TRADEX+1!,WAIT+2!,NOALRGY+14~
                NOALRGY+16
   GOC          POST+54~*,POST+57,POST+60
   I            EN+3*,EN+5*,EN+6,EN+7!
   IOSL         POST+12,POST+16,POST+19,POST+22,POST+31,POST+36,POST+40,POST+46
                POST+48,POST+52,POST+58,POST+62,POST+69,NOALRGY+1
   IT           SELECT+2!,POST+3!,POSTX+1!
   LAB          EN+1!
   LAB(         EN+6*
   LAB("BAD TEST" 
                EN+4*
   LAB("NOT"    EN+1*
   LABT         EN+6*,EN+7!
   LIST         POST+1~*,POST+2,POST+5,POST+6,POST+8,POST+9
   NDC          START+5~,START+6,NDC~,NDC+1*,NDC+11*,NDC+12
   NDF          POST+11~
   NFI          NFI+1*,NFI+2,NFI+3!
   OI           POST+43~*,POST+44
   OIR          POST+43~,POST+44*,POST+47,POST+50
>> OR0          SELECT+2
>> P(5          CLOZ+2*,CLOZ+4!
>> POERR        SELECT+2,SELECT+10
>> PSCAN(       NOALRGY+21
>> PSCAN(0      NOALRGY+19
   PSOCONT      NDC+5~*,NDC+6,NDC+7*,NDC+8*
>> PSODFN       POST+32,POST+44,POST+46,POST+54,POSTX+1,CLOZ+2,NOALRGY+3
>> PSODGCK      POST+14,POST+26,NOALRGY+12,NOALRGY+13
>> PSODGCKX     POST+23
   PSODIR       SELECT+10!
   PSODIR("FIELD" 
                SELECT+10
   PSODIR("FLD" SELECT+10*
   PSODLQT      POST+3!
   PSODOSD      POST+2!,POST+3!
   PSODRG       EO+1!
   PSODRG("QFLG" 
                START+1*,START+9,SELECT+10*,SELECT+17*
>> PSODRUG("BAD" 
                SELECT+2!
>> PSODRUG("CLN" 
                SET+6*
>> PSODRUG("COST" 
                SET+13*
>> PSODRUG("DAW" 
                SELECT+2!,SET+9*
>> PSODRUG("DEA" 
                SET+5*,POST+66
>> PSODRUG("EXPIRATION DATE" 
                SET+15*
>> PSODRUG("IEN" 
                START+4,SELECT+3,SELECT+5,SET+1*,NFI+1,POST+17,POST+38,POST+50
                POST+60,CLOZ+1,CLOZ+2
>> PSODRUG("MAXDOSE" 
                SET+5*
>> PSODRUG("NAME" 
                SELECT+3,SET+2*,POST+54
>> PSODRUG("NDC" 
                START+6*,SELECT+2!,SET+8*
>> PSODRUG("NDF" 
                SET+4*,POST+32
>> PSODRUG("OI" SET+3*,NFI+1,POST+42,POST+43
>> PSODRUG("OIN" 
                SET+3*
>> PSODRUG("SIG" 
                SET+7*
>> PSODRUG("STKLVL" 
                SET+10*
>> PSODRUG("TRADE NAME" 
                SELECT+2!,TRADE+5*
>> PSODRUG("UNIT" 
                SET+14*
>> PSODRUG("VA CLASS" 
                SET+1*,POST+66
>> PSOEDIT      START+2,START+12,SELECT+17
>> PSONCROC     POST+64
>> PSONEW("DFLG" 
                START+1*,START+9,START+12*,SELECT+9*,SELECT+14*,TRADE+4*
>> PSONEW("FIELD" 
                START+1*,START+8,SELECT+10*
>> PSONEW("FLD" SELECT+10
>> PSONEW("OLD VAL" 
                SELECT+3*,SELECT+17,SELECTX!
   PSONOAL      POST+21*!
>> PSONV        NOALRGY+17,NOALRGY+26
   PSOQUIT      POST+11!,POST+24,POSTX+2!
>> PSOREINS     POSTX+2
>> PSORENW("DFLG" 
                POST+28
>> PSORX("DFLG" START+1!,START+12!,POST+10,POST+11*,POST+15,POST+18,POST+24
                POST+27,POST+64,CLOZ+3*,NOALRGY+8*,NOALRGY+18*
>> PSORX("EDIT" START+4,START+8,START+12,TRADE+4
>> PSORX("INTERVENE" 
                POST+11!,POST+23!,POSTX+1!,NOALRGY+26*
>> PSORXED      SELECT+1,SELECT+8,POSTX+2
>> PSORXED("DFLG" 
                START+3,START+4,START+5*,START+9,SELECT+8*,TRADEX*,POST+10
>> PSORXED("FLD" 
                START+6*
>> PSORXED("IRXN" 
                START+5
>> PSOSD        POST+26
>> PSOSITE      NDC+12,SET+8
>> PSOSPRNW     POST+28
>> PSOTRN       TRADE+2
   PSOX1        SET+12*,SET+13,SET+14,SET+15,SETX!
   PSOY         START+4,START+5,SELECT+18!*,SET+1,SET+3,SET+4,SET+6,SET+8,SET+9
                SET+10,SET+11,SET+12,SETX!
   PSOY(0       SELECT+18*,SELECT+19,SET+1,SET+2,SET+5,SET+7
   PSZZQUIT     POSTX+1!,NOALRGY+17*
   PTR          POST+11~
>> REA          NOALRGY+20
   RFL          NDC~,NDC+1,NDC+7,NDC+8,NDC+11,NDC+12
   RX           NDC~,NDC+1,NDC+7,NDC+8,NDC+11,NDC+12,NOALRGY+21
   RXIEN        NOALRGY+14~,NOALRGY+21*,NOALRGY+22,NOALRGY+24
   RXSTA        NOALRGY+14~,NOALRGY+22*,NOALRGY+23
   SIG          POST+11~
   STAT         SET+1~,POST+11~
   U            SELECT+10
   VAP          POST+11~
   X            SELECT+2!,SELECT+4*,SELECT+5*,SELECT+6,SELECT+7,SELECT+8
                SELECT+9,SELECT+10,SELECTX!,TRADE+1!,TRADE+3,TRADEX+1!,POST+35*
                POST+47*,POST+57*,WAIT+2!,CLOZ+2*,CLOZ+4!
   Y            SELECT+2!*,SELECT+3*,SELECT+4,SELECT+5,SELECT+16,SELECT+17
                SELECT+18,SELECTX!,TRADE+1!,TRADE+3*,TRADE+5,TRADEX+1!,WAIT+2!
                NOALRGY+6,NOALRGY+7,NOALRGY+16
   Y(0          SELECT+18
   ZDGDG        POST+3!,POSTX+1!
   ZTHER        POST+3!,POSTX+1!
   ZX           POST+36*,POST+48*,POST+58*,POST+65!

Global Variables  ( * Changed  ! Killed)
   ^%ZOSF("TEST"       CLOZ+3
   ^PS(50.7            SET+3
   ^PSDRUG(            SELECT+2,SET+3,SET+4,SET+6,SET+10,SET+11,SET+12,POST+17
                       CLOZ+1,EN+1,EN+2,EN+3,EN+5,EN+6
   ^TMP("PSODAOC"      POST+2!,POST+4*,POST+8*,POST+38*,POST+50*,POST+60*
   ^TMP("PSORXDC"      POST+2!
   ^TMP($J             POST+2!,POST+5*,POST+6,POST+8,POST+9!,POSTX+1!,NOALRGY+3
   ^UTILITY($J         POST+35!,POST+36,POST+37!,POST+47!,POST+48,POST+49!
                       POST+57!,POST+58,POST+59!
   ^XTMP("ORRDI"       POST+4

Naked Globals
   ^("ND"       SET+4,SET+6
   ^(0          EN+6
   ^(2          SET+3

Cache Objects
   NONE

Marked Items
   NONE

Label References
   @(           START+2,POST+14,POST+71,CLOZ+3
   CLOZ         POST+17
   END          START+3,START+4,START+9
   NDC          START+5
   NFI          START+11
   NOALRGY      POST+21
   POST         START+12
   POSTX        POST+10,POST+15,POST+18,POST+24,POST+27,POST+28,POST+66
   SELECT       SELECT+6,SELECT+7,SELECT+15,SELECT+16
   SELECTX      SELECT+8,SELECT+9,SELECT+10,SELECT+14
   SET          START+10
   SETX         SET+11
   TRADE        START+8,SELECT+19
   TRADEX       TRADE+4

External References
   MIX^DIC1            SELECT+13
   ^DIE                NOALRGY+25
   $$GET1^DIQ          SET+9,NOALRGY+22
   ^DIR                TRADE+2,WAIT+2,NOALRGY+5,NOALRGY+12,NOALRGY+15
   ^DIWP               POST+35,POST+47,POST+57
   $$AOC^OROCAPI       POST+32
   $$DOC^OROCAPI       POST+44
   $$GOC^OROCAPI       POST+54
   $$OITM^ORX8         POST+43
   $$RXRLDT^PSOBPSUT   NDC+7
   $$STATUS^PSOBPSUT   NDC+8
   ^PSOBUILD           POST+13
   CK^PSOCROC          POST+64
   HD^PSODDPR2         POST+12,POST+16,POST+19,POST+22,POST+31,POST+36,POST+40
                       POST+46,POST+48,POST+52,POST+58,POST+62,POST+69
                       NOALRGY+1
   DATACK^PSODDPRE     POST+7
   ^PSODGAL1           POST+23
   JUMP^PSODIR1        SELECT+10
   $$GETNDC^PSONDCUT   NDC+1,NDC+11
   NDCEDT^PSONDCUT     NDC+12
   TD^PSONFI           NFI+2
   ALLERGY^PSOORUT2    POST+21
   $$FIND^PSOREJUT     NDC+8
   ^PSORXI             NOALRGY+7,NOALRGY+27
   DUPINV^PSORXI       NOALRGY+9
   EN1^PSORXI          NOALRGY+26
   PRFLP^PSOUTL        POST+26
   $$PROMPT^PSSDIN     NFI+1
   EN^PSSDIN           NFI+1
   IN^PSSHRQ2          POST+5
   $$GETNDC^PSSNDCUT   SET+8
   DEM^VADPT           POST+46

*****   END   *****


PSON52   * *  213 Lines,  12320 Bytes, Checksum: B98393107
                                                  Jul 01, 2016@06:56:32 page 5
              1018 bytes in comments
PSON52   ;BIR/DSD - files new entries in prescription file ;08/09/93
         ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157
          ,143,219,148,239,201,268,260,225,303,358,251,387,379,390,391,313,408,4
          57**;DEC 1997;Build 10
         ;External reference ^PS(55 supported by DBIA 2228
         ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
         ;External reference to ^XUSEC supported by DBIA 10076
         ;External reference SWSTAT^IBBAPI supported by DBIA 4663
         ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
         ;External reference to $$DS^PSSDSAPI supported by DBIA 5425
EN(PSOX) ;Entry Point
START    ;
         D:$D(XRTL) T0^%ZOSV ; Start RT Monitor
         D INIT G:PSON52("QFLG") END D NFILE Q:$G(PSONEW("DFLG"))
         D PS55,DIK
         S:$D(XRT0) XRTN=$T(+0) D:$D(XRT0) T1^%ZOSV ; Stop RT Monitor
         D FINISH
         I $P(^PSRX(PSOX("IRXN"),0),"^",11)="W",$G(^("IB")) S ^PSRX("ACP",$P(^PS
          RX(PSOX("IRXN"),0),"^",2),$P(^(2),"^",2),0,PSOX("IRXN"))=""
END      D EOJ
         Q
INIT     ;
         K X,%DT S:$G(PSOID) PSOX("ISSUE DATE")=PSOID
         S PSOX("CS")=0 K PSOX("NOPSDRPH")
         F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+
          PSODRUG("DEA"),DEA)<6 S $P(PSOX("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)
          =2 $P(PSOX("CS"),"^",2)=1
         I $P($G(PSOX("CS")),"^"),'$D(^XUSEC("PSDRPH",DUZ)) S PSOX("NOPSDRPH")=1
         S PSON52("QFLG")=0,X1=PSOX("ISSUE DATE"),X2=PSOX("DAYS SUPPLY")*(PSOX("
          # OF REFILLS")+1)\1
         I $D(CLOZPAT) S X2=$S(X2=14:14,X2=7:7,1:X2) G DT
         S X2=$S(PSOX("DAYS SUPPLY")=X2:X2,+$G(PSOX("CS")):184,+$G(DEA("CS")):18
          4,1:366)
         I X2<30 D
         . N % S %=$P($G(PSORX("PATIENT STATUS")),"^"),X2=30
         . S:%?.N %=$P($G(^PS(53,+%,0)),"^") I %["AUTH ABS" S X2=5
DT       D C^%DTC S PSOX("STOP DATE")=$P(X,".") K X
         I PSOX("# OF REFILLS")>0 S X1=PSOX("FILL DATE"),X2=$S((PSOX("DAYS SUPPL
          Y")-10\1)<1:1,1:PSOX("DAYS SUPPLY")-10\1) D C^%DTC S PSOX("NEXT POSSIB
          LE REFILL")=$P(X,".") K X
         S PSOX("TYPE OF RX")=0,PSOX("DISPENSED DATE")=PSOX("FILL DATE") D NOW^%
          DTC S PSOX("LOGIN DATE")=$S($P($G(OR0),"^",12):$P($G(OR0),"^",12),1:%)
           K %,X
         S PSOX("STATUS")=$S($G(PSOX("STATUS"))]"":PSOX("STATUS"),$D(PSORX("VERI
          FY")):1,$D(PSOX("NOPSDRPH")):1,1:0)
         S PSOX("COPIES")=$S($G(PSOX("COPIES"))]"":PSOX("COPIES"),1:1)
         I $G(PSORX("PHARM"))]"" S PSOX("PHARMACIST")=PSORX("PHARM") K PSORX("PH
          ARM")
INITX    Q
         ;
NFILE    I $G(OR0) D  Q:$G(PSONEW("DFLG"))
         .D NOOR^PSONEW Q:$G(PSONEW("DFLG"))
         .I $G(PSOSIGFL)!($G(PSODRUG("OI"))'=$P(OR0,"^",8)) S PSONEW("CLERK CODE
          ")=DUZ,PSONEW("REMARKS")=$G(PSONEW("REMARKS"))_" CPRS Order #"_$P(OR0,
          "^")_" Edited."
         S DIC="^PSRX(",DLAYGO=52,DIC(0)="L",X=PSOX("RX #") K DD,DO D FILE^DICN 
          S PSOX("IRXN")=+Y K DLAYGO,X,Y,DIC,DD,DO
         I '$D(^XUSEC("PSORPH",DUZ))!($D(PSOX("NOPSDRPH"))),$$DS^PSSDSAPI&(+$G(^
          TMP("PSODOSF",$J,0))) S PSON52(PSOX("IRXN"),"STA")=1,PSOX("STATUS")=1
         F PSOX1=0:1 S PSON52=$P($T(DD+PSOX1),";;",2,4) Q:PSON52=""  K PSOY S PS
          OY=$P(PSON52,";;") I $G(@PSOY)]"" S $P(PSON52(PSOX("IRXN"),$P(PSON52,"
          ;;",2)),"^",$P(PSON52,";;",3))=@PSOY
         F I=1:1:PSOX("ENT") S ^PSRX(PSOX("IRXN"),6,I,0)=PSOX("DOSE",I)_"^"_$G(P
          SOX("DOSE ORDERED",I))_"^"_$G(PSOX("UNITS",I))_"^"_$G(PSOX("NOUN",I))_
          "^" D
         .S ^PSRX(PSOX("IRXN"),6,I,0)=^PSRX(PSOX("IRXN"),6,I,0)_$G(PSOX("DURATIO
          N",I))_"^"_$G(PSOX("CONJUNCTION",I))_"^"_$G(PSOX("ROUTE",I))_"^"_$G(PS
          OX("SCHEDULE",I))_"^"_$G(PSOX("VERB",I))
         .I $G(PSOX("ODOSE",I))]"" S ^PSRX(PSOX("IRXN"),6,I,1)=PSOX("ODOSE",I)
         S ^PSRX(PSOX("IRXN"),6,0)="^52.0113^"_PSOX("ENT")_"^"_PSOX("ENT")
         K PSOX1,PSOY
         S PSOX1="" F  S PSOX1=$O(PSON52(PSOX("IRXN"),PSOX1)) Q:PSOX1=""  S ^PSR
          X(PSOX("IRXN"),PSOX1)=$G(PSON52(PSOX("IRXN"),PSOX1))
         I $O(PSOX("SIG",0)) D
         .S D=0 F  S D=$O(PSOX("SIG",D)) Q:'D  S ^PSRX(PSOX("IRXN"),"INS1",D,0)=
          PSOX("SIG",D),TP=$G(TP)+1
         .S ^PSRX(PSOX("IRXN"),"INS1",0)="^52.0115^"_TP_"^"_TP_"^"_DT_"^^" K TP,
          D
         I $G(PSOX("SINS"))]"" S ^PSRX(PSOX("IRXN"),"INSS")=PSOX("SINS")
         I $G(SIGOK) D
         .S $P(^PSRX(PSOX("IRXN"),"SIG"),"^",2)=1,^PSRX(PSOX("IRXN"),"SIG1",0)="
          ^52.04A^^"
         .S D=0 F  S D=$O(SIG(D)) Q:'D  S ^PSRX(PSOX("IRXN"),"SIG1",D,0)=SIG(D),
          $P(^PSRX(PSOX("IRXN"),"SIG1",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"SIG1",0
          ),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1 Q:'$O(SIG(D))
         .K SIG
         I $D(PSOINSFL) S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^1^1",^PSRX(PSOX("IR
          XN"),"A",1,0)=DT_"^G^^0^Patient Instructions "_$S(PSOINSFL=1:"",1:"Not
           ")_"Sent By Provider."
         I $G(OR0),$P(OR0,"^",24) S ^PSRX(PSOX("IRXN"),"PKI")=$S($G(PSOSIGFL):"^
          1",1:1) D ACLOG
         I $P($G(PSOX("CS")),"^"),'+$P($G(^PSRX(PSOX("IRXN"),"PKI")),"^") S $P(^
          PSRX(PSOX("IRXN"),"PKI"),"^",2)=1
         K PSOX1,PSOFINFL,HLDSIG,D,PSOINSFL,D
         D:$G(^TMP("PSODAI",$J,0))
         .S $P(^PSRX(PSOX("IRXN"),3),"^",6)=1
         .I $O(^TMP("PSODAI",$J,0)) S DAI=0 F  S DAI=$O(^TMP("PSODAI",$J,DAI)) Q
          :'DAI  D
         ..S:'$D(^PSRX(PSOX("IRXN"),"DAI",0)) ^PSRX(PSOX("IRXN"),"DAI",0)="^52.0
          3^^" S ^PSRX(PSOX("IRXN"),"DAI",DAI,0)=^TMP("PSODAI",$J,DAI,0)
         ..S $P(^PSRX(PSOX("IRXN"),"DAI",0),"^",3)=+$P(^PSRX(PSOX("IRXN"),"DAI",
          0),"^",3)+1,$P(^(0),"^",4)=+$P(^(0),"^",4)+1
         .K ^TMP("PSODAI",$J),DAI
         I $G(PSOX("CHCS NUMBER"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^")=$G(PS
          OX("CHCS NUMBER"))
         I $G(PSOX("EXTERNAL SYSTEM"))'="" S $P(^PSRX(PSOX("IRXN"),"EXT"),"^",2)
          =$G(PSOX("EXTERNAL SYSTEM"))
         I $G(PSOX("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=$G(PSOX("NEWCOPAY"))
         ;Next line, set SC question based on Copay status?
IBQ      ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,
          1:1)
         N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOA
          NSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOAN
          SQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))_"^"_$G(PSOANSQ
          ("SHAD"))
         I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT S
          TATUS")),0)),"^",7)'=1) D
         . S ^PSRX(PSOX("IRXN"),"IBQ")=PSOSCFLD K PSOSCFLD  ;don't set if SC % i
          s null or 0, just set it in ICD node
         D ICD^PSODIAG
         D:$$SWSTAT^IBBAPI() GACT^PSOPFSU0(PSOX("IRXN"),0)
         D:$G(PSOTITRX) SAVETIT(PSOTITRX,PSOX("IRXN"))
         K PSOTITRX,PSOANSQ,PSOANSQD,PSOX("NEWCOPAY")
         L -^PSRX("B",PSOX("IRXN"))
         Q
         ;
ACLOG    ;activity log (digitally signed CS orders)
         N DTTM,CNT,OCNT,XX
         D NOW^%DTC S DTTM=%
         S CNT=0 F XX=0:0 S XX=$O(^PSRX(PSOX("IRXN"),"A",XX)) Q:'XX  S CNT=XX
         S OCNT=CNT
         I $G(PSOCSP("NAME"))'=PSODRUG("NAME") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A
          ",CNT,0)=DTTM_"^K^"_DUZ_"^0^NAME: "_PSOCSP("NAME")
         S XX=0 F  S XX=$O(PSOCSP("DOSE",XX)) Q:'XX  I PSOCSP("DOSE",XX)'=$G(PSO
          NEW("DOSE",XX)) D
         .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DOSAGE: "
          _PSOCSP("DOSE",XX)
         S XX=0 F  S XX=$O(PSOCSP("DOSE ORDERED",XX)) Q:'XX  I PSOCSP("DOSE ORDE
          RED",XX)'=$G(PSONEW("DOSE ORDERED",XX)) D
         .S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DISPENSE 
          UNITS: "_PSOCSP("DOSE ORDERED",XX)
         I PSOCSP("ISSUE DATE")'=PSONEW("ISSUE DATE") S CNT=CNT+1,^PSRX(PSOX("IR
          XN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ISSUE DATE: "_$$FMTE^XLFDT(PSOCSP("
          ISSUE DATE"))
         I PSOCSP("DAYS SUPPLY")'=PSONEW("DAYS SUPPLY") S CNT=CNT+1,^PSRX(PSOX("
          IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^DAYS SUPPLY: "_PSOCSP("DAYS SUPPL
          Y")
         I PSOCSP("QTY")'=PSONEW("QTY") S CNT=CNT+1,^PSRX(PSOX("IRXN"),"A",CNT,0
          )=DTTM_"^K^"_DUZ_"^0^QTY: "_PSOCSP("QTY")
         I PSOCSP("# OF REFILLS")'=PSONEW("# OF REFILLS") S CNT=CNT+1,^PSRX(PSOX
          ("IRXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^# OF REFILLS: "_PSOCSP("# OF RE
          FILLS")
         I '$$SUBSCRIB^ORDEA($P(OR0,"^"),PSOX("IRXN")) S CNT=CNT+1,^PSRX(PSOX("I
          RXN"),"A",CNT,0)=DTTM_"^K^"_DUZ_"^0^ORDER DEA ARCHIVE INFO file entry 
          failure"
         I OCNT'=CNT S ^PSRX(PSOX("IRXN"),"A",0)="^52.3DA^"_CNT_"^"_CNT
         Q
         ;
PS55     ;
         L +^PS(55,PSODFN,"P"):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
         S:'$D(^PS(55,PSODFN,"P",0)) ^(0)="^55.03PA^^"
         F PSOX1=$P(^PS(55,PSODFN,"P",0),"^",3):1 Q:'$D(^PS(55,PSODFN,"P",PSOX1)
          )
         S PSOX("55 IEN")=PSOX1
         S ^PS(55,PSODFN,"P",PSOX1,0)=PSOX("IRXN"),$P(^PS(55,PSODFN,"P",0),"^",3
          ,4)=PSOX1_"^"_($P(^PS(55,PSODFN,"P",0),"^",4)+1)
         S ^PS(55,PSODFN,"P","A",PSONEW("STOP DATE"),PSOX("IRXN"))=""
PS55X    L -^PS(55,PSODFN,"P")
         K PSOX1
         Q
DIK      ;
         I $D(^XUSEC("PSORPH",DUZ)) S DA=PSOX("IRXN"),DIE=52,DR="41////"_PSOCOU_
          ";S:'X Y=""@1"";42////"_PSOCOUU_";@1" D ^DIE K DIE,DR
         K DIK,DA S DIK="^PSRX(",DA=PSOX("IRXN") D IX1^DIK K DIK
         S DA=PSOX("IRXN") D ORC^PSORN52C
         Q
FINISH   ;
ANQ      ;
          ; ** START NCC REMEDIATION ** 457/RTW
         I $G(ANQDATA)]"" N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK S PSOUSER=$P
          (ANQDATA,"^",5),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",2),PSOREA
          SN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4) D NOW^%DTC G:$D(^PS(52
          .52,"B",%)) ANQ D
         . K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
         . D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
         . N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSOX("IRXN")_";2///
          /"_PSOUSER_";3////"_PSO1PH_";4////"_PSOREASN_";5////"_PSOREMRK_";6////
          "_PSO2PH
         . D ^DIE K DIE,DA,DR
         . K ANQDATA,X,Y,%,ANQREM
         . D ALERT^PSORENW0
         ; ** END NCC REMEDIATION ** 457/RTW
         ;/RBN BEGIN MODIFICATIONS FOR PSO*7.0*457
         I $D(^PSDRUG("ACLOZ",PSODRUG("IEN"))) D ^YSCLTST6
         ;/RBN END MODIFICATIONS FOR PSO*7.0*457
         N PSOTFIN
         I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) S PSOTFIN="",PSOTFIN
          =$$TECH2^PSODGDGP(PSOX("IRXN"),PSODFN,DUZ,.PSOX)
         I $D(PSOX("NOPSDRPH"))!('$D(^XUSEC("PSORPH",DUZ))) G FINISHP:$G(PSOTFIN
          )=1 G FINISHX:$G(PSOTFIN)=2
         ;
         I PSOX("FILL DATE")>DT,$P(PSOPAR,"^",6) S DA=PSOX("IRXN"),RXFL(PSOX("IR
          XN"))=0 D SUS^PSORXL K DA G FINISHX
         ;
         ; - Calling ECME for claims generation and transmission / REJECT handli
          ng
         N ACTION,PSOERX
         S PSOERX=PSOX("IRXN")
         I $$SUBMIT^PSOBPSUT(PSOERX,0) D  I ACTION="Q"!(ACTION="^") Q
         . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,"","OF")
         . ; Quit if there is an unresolved Tricare/CHAMPVA non-billable reject 
          code, PSO*7*358
         . I $$PSOET^PSOREJP3(PSOERX,0) S ACTION="Q" Q
         . I $$FIND^PSOREJUT(PSOERX,0) D
         . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","Q")
         . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
         . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC
          ^PSONDCUT(PSOERX,0))
         ;
FINISHP  ;
         I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=PSOX("IRXN")_",",RXFL(PSOX(
          "IRXN"))=0 G FINISHX
         F PSOX1=0:0 S PSOX1=$O(PSORX("PSOL",PSOX1)) Q:'PSOX1  S PSOX2=PSOX1
         I $L(PSORX("PSOL",PSOX2))+$L(PSOX("IRXN"))<220 S PSORX("PSOL",PSOX2)=PS
          ORX("PSOL",PSOX2)_PSOX("IRXN")_","
         E  S PSORX("PSOL",PSOX2+1)=PSOX("IRXN")_","
         S RXFL(PSOX("IRXN"))=0
FINISHX  ;call to build Rx array for bingo board
         I $G(PSORX("MAIL/WINDOW"))["W" S BINGCRT=1,BINGRTE="W",BBFLG=1 D BBRX^P
          SORN52C
         K PSOX1,PSOX2
         K ^TMP("PSODGI",$J),^TMP("PSOSER",$J),^TMP("PSOSERS",$J),^TMP("PSODGS",
          $J),^TMP("PSOTDD",$J),^TMP("PSODOSF",$J)
         Q
         ;
SAVETIT(TITRX,MNTRX) --
          ; Save Titration/Maintenance dose Rx information
         I '$D(^PSRX(+$G(TITRX),0))!'$D(^PSRX(+$G(MNTRX),0)) Q
         S $P(^PSRX(TITRX,"TIT"),"^",2,3)=MNTRX_"^1"
         D RXACT^PSOBPSU2(TITRX,0,"Maintenance Rx#: "_$$GET1^DIQ(52,MNTRX,.01),"
          E")
         S $P(^PSRX(MNTRX,"TIT"),"^",1)=TITRX
         D RXACT^PSOBPSU2(MNTRX,0,"Titration Rx#: "_$$GET1^DIQ(52,TITRX,.01),"E"
          )
         Q
         ;
EOJ      ;
         ;B xref locked in routine PSONRXN
         L -^PSRX("B",PSOX("IRXN")) K OTHDOS,DA,PSON52,PSOPRC,RTE,SCH,PSOX("INS"
          ),PSONEW("INS"),PSORXED("INS"),PSONEW("ENT"),PSORXED("ENT"),OLENT
         D PSOUL^PSSLOCK(PSOX("IRXN"))
         Q
         ;
         ;;PSOX("SIG");;SIG;;1
DD       ;;PSOX("RX #");;0;;1
         ;;PSOX("ISSUE DATE");;0;;13
         ;;PSODFN;;0;;2
         ;;PSOX("PATIENT STATUS");;0;;3
         ;;PSOX("PROVIDER");;0;;4
         ;;PSOX("CLINIC");;0;;5
         ;;PSODRUG("IEN");;0;;6
         ;;PSODRUG("TRADE NAME");;TN;;1
         ;;PSOX("QTY");;0;;7
         ;;PSOX("DAYS SUPPLY");;0;;8
         ;;PSOX("# OF REFILLS");;0;;9
         ;;PSOX("COPIES");;0;;18
         ;;PSOX("MAIL/WINDOW");;0;;11
         ;;PSOX("REMARKS");;3;;7
         ;;PSOX("ADMINCLINIC");;0;;15 
         ;;PSOX("CLERK CODE");;0;;16
         ;;PSODRUG("COST");;0;;17
         ;;PSOSITE;;2;;9
         ;;PSOX("LOGIN DATE");;2;;1
         ;;PSOX("FILL DATE");;2;;2
         ;;PSOX("PHARMACIST");;2;;3
         ;;PSOX("LOT #");;2;;4
         ;;PSOX("DISPENSED DATE");;2;;5
         ;;PSOX("STOP DATE");;2;;6
         ;;PSODRUG("NDC");;2;;7
         ;;PSODRUG("DAW");;EPH;;1
         ;;PSODRUG("MANUFACTURER");;2;;8
         ;;PSOX("EXPIRATION DATE");;2;;11
         ;;PSOX("GENERIC PROVIDER");;2;;12
         ;;PSOX("RELEASED DATE/TIME");;2;;13
         ;;PSOX("METHOD OF PICK-UP");;MP;;1
         ;;PSOX("STATUS");;STA;;1
         ;;PSOX("LAST DISPENSED DATE");;3;;1
         ;;PSOX("NEXT POSSIBLE REFILL");;3;;2
         ;;PSOX("COSIGNING PROVIDER");;3;;3
         ;;PSOX("TYPE OF RX");;TYPE;;1
         ;;PSOX("SAND");;SAND;;1
         ;;PSOX("POE");;POE;;1
         ;;PSOX("INS");;INS;;1

*****   INDEX OF PSON52   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            INIT+9~*,INIT+10*,DT+2!,ACLOG+2,ANQ+2,ANQ+3,ANQ+7!
   %DT          INIT+1!
   ACTION       ANQ+20~,ANQ+22,ANQ+23*,ANQ+25*,ANQ+27*
   ANQDATA      ANQ+2,ANQ+7!
   ANQREM       ANQ+7!
>> BBFLG        FINISHX+1*
>> BINGCRT      FINISHX+1*
>> BINGRTE      FINISHX+1*
>> CLOZPAT      INIT+6
   CNT          ACLOG+1~,ACLOG+3*,ACLOG+4,ACLOG+5*,ACLOG+7*,ACLOG+9*,ACLOG+10*
                ACLOG+11*,ACLOG+12*,ACLOG+13*,ACLOG+14*,ACLOG+15
   D            NFILE+13*,NFILE+14!,NFILE+18*,NFILE+23!
   DA           DIK+1*,DIK+2!*,DIK+3*,ANQ+4!,ANQ+5*,ANQ+6!,ANQ+17*!,EOJ+2!
   DAI          NFILE+26*,NFILE+27,NFILE+29!
   DD           NFILE+3!,ANQ+3!,ANQ+4!
>> DEA          INIT+3*
>> DEA("CS"     INIT+7
   DIC          NFILE+3*!,ANQ+3*,ANQ+4!
   DIC(0        NFILE+3*,ANQ+3*
   DIE          DIK+1*!,ANQ+5*,ANQ+6!
   DIK          DIK+2!*
   DLAYGO       NFILE+3*!,ANQ+3*,ANQ+4!
   DO           NFILE+3!,ANQ+3!,ANQ+4!
   DR           DIK+1*!,ANQ+4!,ANQ+5*,ANQ+6!
   DT           NFILE+14,NFILE+20,ANQ+17
   DTTM         ACLOG+1~,ACLOG+2*,ACLOG+5,ACLOG+7,ACLOG+9,ACLOG+10,ACLOG+11
                ACLOG+12,ACLOG+13,ACLOG+14
   DUZ          INIT+4,NFILE+2,NFILE+4,ACLOG+5,ACLOG+7,ACLOG+9,ACLOG+10
                ACLOG+11,ACLOG+12,ACLOG+13,ACLOG+14,DIK+1,ANQ+14,ANQ+15
   HLDSIG       NFILE+23!
>> I            NFILE+6*,NFILE+7,NFILE+8
   MNTRX        SAVETIT~,SAVETIT+1,SAVETIT+2,SAVETIT+3,SAVETIT+4,SAVETIT+5
   OCNT         ACLOG+1~,ACLOG+4*,ACLOG+15
   OLENT        EOJ+2!
>> OR0          DT+2,NFILE,NFILE+2,NFILE+21,ACLOG+14
   OTHDOS       EOJ+2!
   PS52         ANQ+5~*
   PSO1PH       ANQ+2~*,ANQ+5
   PSO2PH       ANQ+2~*,ANQ+5
   PSOANSQ      IBQ+7!
   PSOANSQ("CV" IBQ+1
   PSOANSQ("HNC" 
                IBQ+1
   PSOANSQ("MST" 
                IBQ+1
   PSOANSQ("PGW" 
                IBQ+1
   PSOANSQ("RAD" 
                IBQ+1
   PSOANSQ("SC" IBQ+1
   PSOANSQ("SHAD" 
                IBQ+1
   PSOANSQ("VEH" 
                IBQ+1
   PSOANSQD     IBQ+7!
>> PSOCOU       DIK+1
>> PSOCOUU      DIK+1
>> PSOCSP("# OF REFILLS" 
                ACLOG+13
>> PSOCSP("DAYS SUPPLY" 
                ACLOG+11
>> PSOCSP("DOSE ORDERED" 
                ACLOG+8,ACLOG+9
>> PSOCSP("DOSE" 
                ACLOG+6,ACLOG+7
>> PSOCSP("ISSUE DATE" 
                ACLOG+10
>> PSOCSP("NAME" 
                ACLOG+5
>> PSOCSP("QTY" ACLOG+12
>> PSODFN       PS55+1,PS55+2,PS55+3,PS55+5,PS55+6,PS55X,ANQ+14
>> PSODRUG("DEA" 
                INIT+3
>> PSODRUG("IEN" 
                ANQ+11
>> PSODRUG("NAME" 
                ACLOG+5
>> PSODRUG("OI" NFILE+2
   PSOERX       ANQ+20~,ANQ+21*,ANQ+22,ANQ+23,ANQ+25,ANQ+26,ANQ+27,ANQ+28
                ANQ+29
   PSOFINFL     NFILE+23!
>> PSOID        INIT+1
   PSOINSFL     NFILE+20,NFILE+23!
   PSON52       NFILE+5*,EOJ+2!
   PSON52(      NFILE+4*,NFILE+5*,NFILE+11
   PSON52("QFLG" 
                START+2,INIT+5*
>> PSONEW("# OF REFILLS" 
                ACLOG+13
>> PSONEW("CLERK CODE" 
                NFILE+2*
>> PSONEW("DAYS SUPPLY" 
                ACLOG+11
>> PSONEW("DFLG" 
                START+2,NFILE,NFILE+1
>> PSONEW("DOSE ORDERED" 
                ACLOG+8
>> PSONEW("DOSE" 
                ACLOG+6
>> PSONEW("ENT" EOJ+2!
>> PSONEW("INS" EOJ+2!
>> PSONEW("ISSUE DATE" 
                ACLOG+10
>> PSONEW("PATIENT STATUS" 
                IBQ+2
>> PSONEW("QTY" ACLOG+12
>> PSONEW("REMARKS" 
                NFILE+2*
>> PSONEW("STOP DATE" 
                PS55+6
>> PSOPAR       ANQ+17
   PSOPRC       EOJ+2!
   PSOREASN     ANQ+2~*,ANQ+5
   PSOREMRK     ANQ+2~*,ANQ+5
>> PSORX("MAIL/WINDOW" 
                FINISHX+1
>> PSORX("PATIENT STATUS" 
                INIT+9
>> PSORX("PHARM" 
                DT+5!
>> PSORX("PSOL" FINISHP+1*,FINISHP+2,FINISHP+3*,FINISHP+4*
>> PSORX("VERIFY" 
                DT+3
>> PSORXED("ENT" 
                EOJ+2!
>> PSORXED("INS" 
                EOJ+2!
   PSOSCFLD     IBQ+1~*,IBQ+2,IBQ+3!
>> PSOSCP       IBQ+1,IBQ+2
>> PSOSIGFL     NFILE+2,NFILE+21
>> PSOSITE      ANQ+29
   PSOTFIN      ANQ+13~,ANQ+14*,ANQ+15
   PSOTITRX     IBQ+6,IBQ+7!
   PSOUSER      ANQ+2~*,ANQ+5
   PSOX         EN~,ANQ+14
   PSOX("# OF REFILLS" 
                INIT+5,DT+1
   PSOX("55 IEN" 
                PS55+4*
   PSOX("CHCS NUMBER" 
                NFILE+30
   PSOX("CONJUNCTION" 
                NFILE+7
   PSOX("COPIES" 
                DT+4*
   PSOX("CS"    INIT+2*,INIT+3*,INIT+4,INIT+7,NFILE+22
   PSOX("DAYS SUPPLY" 
                INIT+5,INIT+7,DT+1
   PSOX("DISPENSED DATE" 
                DT+2*
   PSOX("DOSE ORDERED" 
                NFILE+6
   PSOX("DOSE"  NFILE+6
   PSOX("DURATION" 
                NFILE+7
   PSOX("ENT"   NFILE+6,NFILE+9
   PSOX("EXTERNAL SYSTEM" 
                NFILE+31
   PSOX("FILL DATE" 
                DT+1,DT+2,ANQ+17
   PSOX("INS"   EOJ+2!
   PSOX("IRXN"  START+6,NFILE+3*,NFILE+4,NFILE+5,NFILE+6,NFILE+7,NFILE+8
                NFILE+9,NFILE+11,NFILE+13,NFILE+14,NFILE+15,NFILE+17,NFILE+18
                NFILE+20,NFILE+21,NFILE+22,NFILE+25,NFILE+27,NFILE+28,NFILE+30
                NFILE+31,NFILE+32,IBQ+3,IBQ+5,IBQ+6,IBQ+8,ACLOG+3
                ACLOG+5,ACLOG+7,ACLOG+9,ACLOG+10,ACLOG+11,ACLOG+12,ACLOG+13
                ACLOG+14,ACLOG+15,PS55+5,PS55+6,DIK+1,DIK+2,DIK+3,ANQ+5,ANQ+14
                ANQ+17,ANQ+21,FINISHP+1,FINISHP+3,FINISHP+4,FINISHP+5,EOJ+2
                EOJ+3
   PSOX("ISSUE DATE" 
                INIT+1*,INIT+5
   PSOX("LOGIN DATE" 
                DT+2*
   PSOX("NEWCOPAY" 
                NFILE+32,IBQ+7!
   PSOX("NEXT POSSIBLE REFILL" 
                DT+1*
   PSOX("NOPSDRPH" 
                INIT+2!,INIT+4*,DT+3,NFILE+4,ANQ+14,ANQ+15
   PSOX("NOUN"  NFILE+6
   PSOX("ODOSE" NFILE+8
   PSOX("PHARMACIST" 
                DT+5*
   PSOX("ROUTE" NFILE+7
   PSOX("RX #"  NFILE+3
   PSOX("SCHEDULE" 
                NFILE+7
   PSOX("SIG"   NFILE+12,NFILE+13
   PSOX("SINS"  NFILE+15
   PSOX("STATUS" 
                DT+3*,NFILE+4*
   PSOX("STOP DATE" 
                DT*
   PSOX("TYPE OF RX" 
                DT+2*
   PSOX("UNITS" NFILE+6
   PSOX("VERB"  NFILE+7
   PSOX1        NFILE+5*,NFILE+10!,NFILE+11*,NFILE+23!,PS55+3*,PS55+4,PS55+5
                PS55X+1!,FINISHP+2*,FINISHX+2!
   PSOX2        FINISHP+2*,FINISHP+3,FINISHP+4,FINISHX+2!
   PSOY         NFILE+5!*,NFILE+10!
   RTE          EOJ+2!
>> RXFL(        ANQ+17*,FINISHP+1*,FINISHP+5*
   SCH          EOJ+2!
   SIG          NFILE+19!
   SIG(         NFILE+18
>> SIGOK        NFILE+16
   TITRX        SAVETIT~,SAVETIT+1,SAVETIT+2,SAVETIT+3,SAVETIT+4,SAVETIT+5
   TP           NFILE+13*,NFILE+14!
   X            INIT+1!,DT!,DT+1!,DT+2!,NFILE+3*!,ANQ+3*,ANQ+7!
>> X1           INIT+5*,DT+1*
>> X2           INIT+5*,INIT+6*,INIT+7*,INIT+8,INIT+9*,INIT+10*,DT+1*
>> XRT0         START+4
>> XRTL         START+1
>> XRTN         START+4*
   XX           ACLOG+1~,ACLOG+3*,ACLOG+6*,ACLOG+7,ACLOG+8*,ACLOG+9
   Y            NFILE+3!,ANQ+5,ANQ+7!

Global Variables  ( * Changed  ! Killed)
   ^DD("DILOCKTM"      PS55+1
   ^PS(52.52           ANQ+2
   ^PS(53              INIT+10,IBQ+2
   ^PS(55              PS55+1,PS55+2,PS55+3,PS55+5*,PS55+6*,PS55X
   ^PSDRUG("ACLOZ"     ANQ+11
   ^PSRX(              START+6,NFILE+6*,NFILE+7*,NFILE+8*,NFILE+9*,NFILE+11*
                       NFILE+13*,NFILE+14*,NFILE+15*,NFILE+17*,NFILE+18*
                       NFILE+20*,NFILE+21*,NFILE+22*,NFILE+25*,NFILE+27*
                       NFILE+28*,NFILE+30*,NFILE+31*,NFILE+32*,IBQ+3*,ACLOG+3
                       ACLOG+5*,ACLOG+7*,ACLOG+9*
                       ACLOG+10*,ACLOG+11*,ACLOG+12*,ACLOG+13*,ACLOG+14*
                       ACLOG+15*,SAVETIT+1,SAVETIT+2*,SAVETIT+4*
   ^PSRX("ACP"         START+6*
   ^PSRX("B"           IBQ+8,EOJ+2
   ^TMP("PSODAI"       NFILE+24,NFILE+26,NFILE+27,NFILE+29!
   ^TMP("PSODGI"       FINISHX+3!
   ^TMP("PSODGS"       FINISHX+3!
   ^TMP("PSODOSF"      NFILE+4,FINISHX+3!
   ^TMP("PSOSER"       FINISHX+3!
   ^TMP("PSOSERS"      FINISHX+3!
   ^TMP("PSOTDD"       FINISHX+3!
   ^XUSEC("PSDRPH"     INIT+4
   ^XUSEC("PSORPH"     NFILE+4,DIK+1,ANQ+14,ANQ+15

Naked Globals
   ^("IB"       START+6
   ^(0          NFILE+18*,NFILE+28*,PS55+2*
   ^(2          START+6

Cache Objects
   NONE

Marked Items
   $T(          START+4
   $T(DD+PSOX1  NFILE+5

Label References
   ACLOG        NFILE+21
   ANQ          ANQ+2
   DIK          START+3
   DT           INIT+6
   END          START+2
   EOJ          END
   FINISH       START+5
   FINISHP      ANQ+15
   FINISHX      ANQ+15,ANQ+17,FINISHP+1
   INIT         START+2
   NFILE        START+2
   PS55         START+3
   SAVETIT      IBQ+6

External References
   C^%DTC              DT,DT+1
   NOW^%DTC            DT+2,ACLOG+2,ANQ+2
   T0^%ZOSV            START+1
   T1^%ZOSV            START+4
   FILE^DICN           NFILE+3,ANQ+4
   ^DIE                DIK+1,ANQ+6
   IX1^DIK             DIK+2
   $$GET1^DIQ          ANQ+29,SAVETIT+3,SAVETIT+5
   $$SWSTAT^IBBAPI     IBQ+5
   $$SUBSCRIB^ORDEA    ACLOG+14
   ECMESND^PSOBPSU1    ANQ+23
   RXACT^PSOBPSU2      SAVETIT+3,SAVETIT+5
   $$STATUS^PSOBPSUT   ANQ+28
   $$SUBMIT^PSOBPSUT   ANQ+22
   $$TECH2^PSODGDGP    ANQ+14
   ICD^PSODIAG         IBQ+4
   $$GETNDC^PSONDCUT   ANQ+29
   NOOR^PSONEW         NFILE+1
   GACT^PSOPFSU0       IBQ+5
   $$PSOET^PSOREJP3    ANQ+25
   $$HDLG^PSOREJU1     ANQ+27
   $$FIND^PSOREJUT     ANQ+26
   ALERT^PSORENW0      ANQ+8
   BBRX^PSORN52C       FINISHX+1
   ORC^PSORN52C        DIK+3
   SUS^PSORXL          ANQ+17
   $$DS^PSSDSAPI       NFILE+4
   PSOUL^PSSLOCK       EOJ+3
   SAVNDC^PSSNDCUT     ANQ+29
   $$FMTE^XLFDT        ACLOG+10
   ^YSCLTST6           ANQ+11

*****   END   *****


PSONEW1  * *  93 Lines,  3890 Bytes, Checksum: B17324644
                                                  Jul 01, 2016@06:56:32 page 6
              544 bytes in comments
PSONEW1  ;BIR/DSD - new Rx order entry ;10/17/92
         ;;7.0;OUTPATIENT PHARMACY;**46,104,117,143,457**;DEC 1997;Build 10
         ;External reference ^PS(55 supported by DBIA 2228
         ;
START    ;
         S (PSONEW("DFLG"),PSONEW("FIELD"),PSONEW1)=0
         ;
1        S PSONEW("FLD")=1 S PSONEW("FIELD")=0
         I $P($G(PSOPAR),"^",7)'=1 D MANUAL^PSONRXN ; Get Manual Rx number
         G:PSONEW("QFLG")!PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
2        S PSONEW("FLD")=2 D PTSTAT^PSODIR1(.PSONEW) ; Get Patient Status
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
3        S PSONEW("FLD")=3 D ^PSODRG  ; Get drug and related information
         G:PSONEW("DFLG") END D EN^PSODIAG  ; get ICD diagnosis codes for order
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
         ;/RBN - BEGIN CHANGES PSO*7.0*457
         ;31 S PSONEW("FLD")=31 D DOSE^PSODIR(.PSONEW) ; Get Dosing
31       I $D(^TMP("CLOZFLG")) D  G 32
         . S PSONEW("# OF REFILLS")=0
         . S PSONEW("DAYS SUPPLY")=4
         . S PSONEW("DOSE",1)=100
         . S PSONEW("DOSE ORDERED",1)=1
         . S PSONEW("DURATION",1)=4
         . S PSONEW("QTY")=4
         . S PSONEW("ENT")=1
         S PSONEW("FLD")=31 D DOSE^PSODIR(.PSONEW) ; Get Dosing
         ;/RBN - END CHANGES PSO*7.0*457
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
32       I '$G(PSONEW("ENT")) W !,"Incomplete Dosaging Data!",! K DIRUT G 31
         S PSONEW("FLD")=32 D INS^PSODIR(.PSONEW) ; Get Patient Instructions
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         I $P($G(^PS(55,PSODFN,"LAN")),"^") D SINS^PSODIR(.PSONEW)
         ;
4        D EN^PSOFSIG(.PSONEW) I $O(SIG(0)) S SIGOK=1
         ;S PSONEW("FLD")=4 D SIG^PSODIR1(.PSONEW) ; Get Rx directions
         ;G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
         ;/RBN - BEGIN CHANGES PSO*7.0*457
         I $G(^TMP("CLOZFLG")) G 6
         ;/RBN - END CHANGES PSO*7.0*457
7        S PSONEW("FLD")=7 D DAYS^PSODIR1(.PSONEW) ; Get days supply
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
5        S PSONEW("FLD")=5 D QTY^PSODIR1(.PSONEW) ; Get quantity
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
6        I $P($G(PSOPAR),"^",15) S PSONEW("FLD")=6 D COPIES^PSODIR1(.PSONEW) ; G
          et label copies
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
         ;/RBN - BEGIN CHANGES PSO*7.0*457
         ;8 S PSONEW("FLD")=8 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
8        I $G(^TMP("CLOZFLG")) G 9
         S PSONEW("FLD")=8 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;/RBN - END CHANGES PSO*7.0*457
         ;
9        S PSONEW("FLD")=9 D PROV^PSODIR(.PSONEW) ; Get Provider
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         G:$G(DUZ("AG"))'="I" 11
         ;
10       Q:$G(DUZ("AG"))'="I"  S PSONEW("FLD")=10 D EXP^PSODIR2(.PSONEW) ; Get E
          xpiration Date - Indian Health Service ONLY
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
11       S PSONEW("FLD")=11 D CLINIC^PSODIR2(.PSONEW) ; Get Clinic
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
12       S PSONEW("FLD")=12 D MW^PSODIR2(.PSONEW) ; Get Mail/Window Info
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
13       S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
14       S PSONEW("FLD")=14 D ISSDT^PSODIR2(.PSONEW) ; Get Issue Date
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
15       S PSONEW("FLD")=15 D FILLDT^PSODIR2(.PSONEW) ; Get Fill date
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
16       S PSONEW("FLD")=16 D CLERK^PSODIR2(.PSONEW) ; Get Clerk Code
         G:PSONEW("DFLG") END G:PSONEW("FIELD") @PSONEW("FIELD")
         ;
END      ;
         K PSONEW1,^TMP("CLOZFLG")
         Q
         ;
JUMP     ;
         S PSONEW("FIELD")=$S(+Y=.01:1,+Y=3:2,+Y=6:3,+Y=10:4,+Y=7:5,+Y=10.6:6,+Y
          =8:7,+Y=9:8,+Y=4:9,+Y=29:10,+Y=5:11,+Y=11:12,+Y=12:13,+Y=1:14,+Y=22:15
          ,+Y=16:16,+Y=113:31,+Y=114:32,1:PSONEW("FLD"))
         I PSONEW("FIELD")>PSONEW("FLD") W !,$C(7),"Cannot jump ahead ..",! S PS
          ONEW("FIELD")=PSONEW("FLD")
         Q

*****   INDEX OF PSONEW1   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   DIRUT        32!
   DUZ("AG"     9+2,10
>> PSODFN       32+3
>> PSONEW       2,31+8,32+1,32+3,4,7,5,6,8+1,9,10,11,12,13,14,15,16
>> PSONEW("# OF REFILLS" 
                31+1*
>> PSONEW("DAYS SUPPLY" 
                31+2*
>> PSONEW("DFLG" 
                START+1*,1+2,2+1,3+1,3+2,31+10,32+2,7+1,5+1,6+1,8+2,9+1,10+1
                11+1,12+1,13+1,14+1,15+1,16+1
>> PSONEW("DOSE ORDERED" 
                31+4*
>> PSONEW("DOSE" 
                31+3*
>> PSONEW("DURATION" 
                31+5*
>> PSONEW("ENT" 31+7*,32
>> PSONEW("FIELD" 
                START+1*,1*,1+2,2+1,3+2,31+10,32+2,7+1,5+1,6+1,8+2,9+1,10+1
                11+1,12+1,13+1,14+1,15+1,16+1,JUMP+1*,JUMP+2*
>> PSONEW("FLD" 1*,2*,3*,31+8*,32+1*,7*,5*,6*,8+1*,9*,10*,11*,12*,13*,14*,15*
                16*,JUMP+1,JUMP+2
>> PSONEW("QFLG" 
                1+2
>> PSONEW("QTY" 31+6*
   PSONEW1      START+1*,END+1!
>> PSOPAR       1+1,6
>> SIG(0        4
>> SIGOK        4*
>> Y            JUMP+1

Global Variables  ( * Changed  ! Killed)
   ^PS(55              32+3
   ^TMP("CLOZFLG"      31,4+5,8,END+1!

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   6            4+5
   9            8
   11           9+2
   31           32
   32           31
   @(           1+2,2+1,3+2,31+10,32+2,7+1,5+1,6+1,8+2,9+1,10+1,11+1,12+1,13+1
                14+1,15+1,16+1
   END          1+2,2+1,3+1,3+2,31+10,32+2,7+1,5+1,6+1,8+2,9+1,10+1,11+1,12+1
                13+1,14+1,15+1,16+1

External References
   EN^PSODIAG          3+1
   DOSE^PSODIR         31+8
   INS^PSODIR          32+1
   PROV^PSODIR         9
   SINS^PSODIR         32+3
   COPIES^PSODIR1      6
   DAYS^PSODIR1        7
   PTSTAT^PSODIR1      2
   QTY^PSODIR1         5
   REFILL^PSODIR1      8+1
   CLERK^PSODIR2       16
   CLINIC^PSODIR2      11
   EXP^PSODIR2         10
   FILLDT^PSODIR2      15
   ISSDT^PSODIR2       14
   MW^PSODIR2          12
   RMK^PSODIR2         13
   ^PSODRG             3
   EN^PSOFSIG          4
   MANUAL^PSONRXN      1+1

*****   END   *****


PSORENW0 * *  220 Lines,  11006 Bytes, Checksum: B97862275
                                                  Jul 01, 2016@06:56:32 page 7
              670 bytes in comments
PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
         ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206,251
          ,375,379,372,411,457**;DEC 1997;Build 10
         ;External reference to ^PS(50.7 supported by DBIA 2223
         ;External reference to ^PSDRUG supported by DBIA 221
         ;External reference to PSOL^PSSLOCK supported by DBIA 2789
         ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
         ;
         ;PSO*237 was not adding to Clozapine Override file, fix
PROCESS  ;
         D ^PSORENW1
         D INST2^PSORENW
         I $D(PSORX("BAR CODE")),PSODFN'=PSORENW("PSODFN") D NEWPT
         S PSORENW("DFLG")=0,PSORENW("FILL DATE")=PSORNW("FILL DATE")
         I $G(PSORNW("MAIL/WINDOW"))]"" S PSORENW("MAIL/WINDOW")=PSORNW("MAIL/WI
          NDOW")
         W !!,"Now Renewing Rx # "_PSORENW("ORX #")_"   Drug: "_$P($G(^PSDRUG(+$
          G(PSORENW("DRUG IEN")),0)),"^"),!
         D CHECK G:PSORENW("DFLG") PROCESSX
         D FILDATE
         D DRUG G:PSORENW("DFLG")!PSORX("DFLG") PROCESSX
         D RXN G:PSORENW("DFLG") PROCESSX
         D STOP^PSORENW1,OERR^PSORENW1:$G(PSOFDR)
DSPL     K PSOEDT,PSOLM D DSPLY^PSORENW3 G:PSORENW("DFLG") PROCESSX
         S PSORENW("QFLG")=0 D:'$G(PSOFDR) EDIT
         G:PSORENW("DFLG")!$G(PSORX("FN")) PROCESSX
         G:'$G(PSORX("FN"))&('$G(PSORENW("QFLG"))) DSPL
         D:$D(^XUSEC("PSORPH",DUZ))!('$P(PSOPAR,"^",2)) VER1^PSOORNE4(.PSORENW) 
          I PSORENW("DFLG")=1 G PROCESSX
         I $G(NEWDOSE),PSORENW("ENT")>0 K NEWDOSE G DSPL
         D EN^PSORN52(.PSORENW)
         D RNPSOSD^PSOUTIL
         D CAN,DCORD^PSONEW2
         S BBRN="",BBRN1=$O(^PSRX("B",PSORENW("NRX #"),BBRN)) I $P($G(^PSRX(BBRN
          1,0)),"^",11)["W" S BINGCRT="Y",BINGRTE="W"
         ;PSO*237 add to Clozapine Override file
ANQ      I $G(ANQDATA)]"" N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK S PSOUSER=$P
          (ANQDATA,"^",5),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"^",2),PSOREA
          SN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4) D NOW^%DTC G:$D(^PS(52
          .52,"B",%)) ANQ D
         .;; ** START NCC REMEDIATION ** 457/RTW
         .N PSOUSER,PSO1PH,PSO2PH,PSOREASN,PSOREMRK,PSOPROV
         .S PSOPROV=$P(ANQDATA,"^",5),PSO1PH=$P(ANQDATA,"^"),PSO2PH=$P(ANQDATA,"
          ^",2),PSOREASN=$P(ANQDATA,"^",3),PSOREMRK=$P(ANQDATA,"^",4)
         .I $D(ORO) S PSOPROV=$P(ORO,"^",4)
         .K DD,DO S DIC="^PS(52.52,",DIC(0)="L",DLAYGO=52.52,X=%
         .D FILE^DICN K DIC,DLAYGO,DD,DO,DA,DR
         .N PS52 S (PS52,DA)=+Y,DIE="^PS(52.52,",DR="1////"_PSORENW("IRXN")_";2/
          ///"_PSO1PH_";3////"_PSOPROV_";4////"_PSOREASN_";5////"_PSOREMRK_";6//
          //"_PSO2PH
         .D ^DIE K DIE,DA,DR
         .K ANQDATA,X,Y,%,ANQREM
         .D ALERT
         ; ** END NCC REMEDIATION ** 457/RTW
         ;
PROCESSX N PSORWRIT I PSORENW("DFLG")!$G(PSORX("DFLG")) S PSOBBCLK=1 W:'$G(POERR
          ) !,$C(7),"RENEWED RX DELETED",! S PSOWRIT=1,PSORERR=1 D
         .D:$P($G(PSOLST(+$G(ORN))),"^",2) PSOUL^PSSLOCK($P(PSOLST(ORN),"^",2)) 
          S POERR("DFLG")=1 D CLEAN^PSOVER1 D
         ..W !! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")=
          "Press Return to Continue" D ^DIR K DIR,DTOUT,DUOUT S VALMBCK="Q"
         D:$G(PSORENW("OLD FILL DATE"))]"" SUSDATEK^PSOUTIL(.PSORENW)
         K PRC,PHI,PSOQUIT,BBRN,BBRN1,PSORENW,PSODRUG,PSORX("PROVIDER NAME"),PSO
          RX("CLINIC"),PSORX("FN")
         K PSOEDT,PSOLM S:$G(PSORENW("FROM"))="" (PSORENW("DFLG"),PSORENW("QFLG"
          ))=0
         D CLEAN^PSOVER1
         Q
         ;
CHECK    ;
         I '$D(PSORX("BAR CODE")),PSORENW("PSODFN")'=PSODFN D  G CHECKX
         .W !!,?5,$C(7),"Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", it is not 
          for this patient." S PSORENW("DFLG")=1
         .S:$G(POERR) VALMSG="Can't renew Rx # "_$P(PSORENW("RX0"),"^")_", not f
          or this patient.",VALMBCK="R"
         ;Invalid dosage check
         N PSOOCPRX,PSOOLPF,PSOOLPD,PSONOSIG S PSOOCPRX=PSORENW("OIRXN") D CDOSE
         I PSOOLPF!(PSONOSIG) D  G CHECKX
         .S PSORENW("DFLG")=1
         .W !!,$C(7),"Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOOLPF:", i
          nvalid dosage of "_$G(PSOOLPD),1:", Missing Sig")
         .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_$S(PSOO
          LPF:", invalid Dosage of "_$G(PSOOLPD),1:", Missing Sig") S VALMBCK="R
          "
         .I '$G(PSORNSPD) W ! K DIR S DIR(0)="E",DIR("?")="Press Return to conti
          nue",DIR("A")="Press Return to Continue" D ^DIR K DIR
         .I $G(PSORNSPD) W !
         ;
         N PSOS S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT N DRG
         I $G(PSOSD) F  S PSOS=$O(PSOSD(PSOS)) Q:PSOS=""  F  S PSOX=$O(PSOSD(PSO
          S,PSOX)) Q:PSOX']""!(PSORENW("DFLG"))  I PSORENW("OIRXN")=+PSOSD(PSOS,
          PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D  K ACOM,D
          IR,DIRUT,DIRUT,DUOUT
         . S PSORENW("DFLG")=1
         . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
         . S PSOREA=$P(PSOY,"^",3),PSOSTAT=+PSORENW("STA")
         . D STATUS^PSOUTIL(PSOREA,PSOSTAT) K PSOREA,PSOSTAT
         .I $G(ACOM)]"" D
         ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
         ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending 
          Order",DIR("A")="for "_DRG,DIR("B")="No"
         ..D ^DIR I 'Y!($D(DIRUT)) Q
         ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
         .Q
         I PSOY="",'$G(PSOORRNW) D
         .W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")," later Rx exist
          s." S PSORENW("DFLG")=1
         .S:$G(POERR) VALMSG="Cannot renew Rx # "_$P(PSORENW("RX0"),"^")_" later
           Rx exists.",VALMBCK="R"
         K PSOX,PSOY G:PSORENW("DFLG") CHECKX
         ;
         I $A($E(PSORENW("ORX #"),$L(PSORENW("ORX #"))))'<90 D  Q
         . W !,$C(7),"Cannot renew Rx # "_PSORENW("ORX #")_", Max number of rene
          wals reached."
         .S:$G(POERR)!('$G(SPEED)) (ACOM,VALMSG)="Cannot renew Rx # "_PSORENW("O
          RX #")_", Max number reached.",VALMBCK="R"
         . S PSORENW("DFLG")=1
         .I $G(OR0)]"" D
         ..S DRG=$P(^PSDRUG($P(^PSRX(PSORENW("OIRXN"),0),"^",6),0),"^")
         ..W ! S DIR(0)="Y",DIR("A",1)="Do you want to Discontinue this Pending 
          Order",DIR("A")="for "_DRG,DIR("B")="No"
         ..D ^DIR I 'Y!($D(DIRUT)) Q
         ..D NOOR^PSOCAN4 Q:$D(DIRUT)  D DE^PSOORFI2
         .K ACOM Q
         D CHKDIV G:PSORENW("DFLG") CHECKX
         ;
         D CHKPRV^PSOUTIL
CHECKX   Q
         ;
CHKDIV   ;
         G:$P(PSORENW("RX2"),"^",9)=+PSOSITE CHKDIVX
         W !?5,$C(7),"RX # ",$P(PSORENW("RX0"),"^")," is for (",$P(^PS(59,$P(PSO
          RENW("RX2"),"^",9),0),"^"),") division."
         I '$P($G(PSOSYS),"^",2) S PSORENW("DFLG")=1 G CHKDIVX
         D:$P($G(PSOSYS),"^",3) DIR
CHKDIVX  Q
         ;
DRUG     ;
         K PSOY
         S PSOY=PSORENW("DRUG IEN"),PSOY(0)=^PSDRUG(PSOY,0),PSORENWD=1
         I '$P($G(^PSDRUG(PSOY,2)),"^") D  Q:$G(PSORX("DFLG"))
         .I $P($G(^PSRX(PSORENW("OIRXN"),"OR1")),"^") S PSODRUG("OI")=$P(^PSRX(P
          SORENW("OIRXN"),"OR1"),"^"),PSODRUG("OIN")=$P(^PS(50.7,+^("OR1"),0),"^
          ") Q
         .W !!,"Cannot Renew!!  No Pharmacy Orderable Item!" S VALMSG="Cannot Re
          new!!  No Pharmacy Orderable Item!",PSORX("DFLG")=1
         D SET^PSODRG
         D POST^PSODRG D:'PSORX("DFLG") DOSCK^PSODOSUT("R") S:$G(PSORX("DFLG")) 
          PSORENW("DFLG")=1 ;remove order checks for v7. do allergy checks only
         S PSONOOR=PSORENW("NOO")
         K PSORX("INTERVENE")
         S:$D(PSONEW("STATUS")) PSORENW("STATUS")=PSONEW("STATUS")
         K PSOY,PSONEW("STATUS"),PSORENWD
         Q
         ;
RXN      ;
         K PSOX
         S PSOX=$E(PSORENW("ORX #"),$L(PSORENW("ORX #")))
         S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("ORX #")_"A",1:$E(PSORENW("ORX #"
          ),1,$L(PSORENW("ORX #"))-1)_$C($A(PSOX)+1))
RETRY    I $O(^PSRX("B",PSORENW("NRX #"),0)) D  G:'$G(PSORENW("DFLG")) RETRY
         .W:$A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))'=90 !,"Rx # "_PSORENW(
          "NRX #")_" is already on file."
         .S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file."
         .I $A($E(PSORENW("NRX #"),$L(PSORENW("ORX #"))))=90 D
         ..W !,"Rx # "_PSORENW("NRX #")_" is already on file. Cannot renew Rx #"
          _PSORENW("ORX #")_".",!,"A new Rx must be entered.",!
         ..S:$G(PSOFDR) VALMSG="Rx # "_PSORENW("NRX #")_" is already on file. Ca
          nnot renew Rx #"_PSORENW("ORX #")_". A new Rx must be entered."
         ..K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Pres
          s Return to Continue" D ^DIR K DIR
         ..S:$G(POERR)!($G(PSOFDR)) VALMSG="Cannot renew Rx # "_PSORENW("ORX #")
          _", Max number reached.",VALMBCK="R" S PSORENW("DFLG")=1
         .S PSOX=$E(PSORENW("NRX #"),$L(PSORENW("NRX #")))
         .S PSORENW("NRX #")=$S(PSOX?1N:PSORENW("NRX #")_"A",1:$E(PSORENW("NRX #
          "),1,$L(PSORENW("NRX #"))-1)_$C($A(PSOX)+1))
RXNX     K PSOX
         Q
         ;
FILDATE  ;
         S PSORENW("IRXN")=PSORENW("OIRXN")
         D NEXT^PSOUTIL(.PSORENW)
         I PSORENW("FILL DATE")<$P(PSORENW("RX3"),"^",2) D
         .D RENFDT^PSOUTIL(.PSORENW)
         .I PSORENW("FILL DATE")<DT,PSORENW("FILL DATE")<PSORNW("FILL DATE") S (
          Y,PSORENW("FILL DATE"))=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
         K PSORENW("IRXN")
         Q
         ;
EDIT     ;
         K DIR,X,Y
         S DIR(0)="Y",DIR("B")=$S($G(DUZ("AG"))'="I":"Y",$G(PSEXDT):"Y",1:"N")
         S DIR("A")="Edit renewed Rx ",DIR("?")="Answer YES to edit the renewed 
          Rx, NO not to."
         D ^DIR K DIR S:$D(DIRUT) PSORENW("DFLG")=1
         G:PSORENW("DFLG") EDITX
         K PSOQUIT,PSORX("FN") I Y S PSORNALL=1 D INIT^PSORENW3,EN^PSOORNE4(.PSO
          RENW) K PSORNALL S:$G(PSOQUIT) PSORENW("DFLG")=1 I '$G(PSORX("FN")) D 
          FULL^VALM1 Q
         Q:$G(PSORX("FN"))
EDITX    S PSOEDT=1,VALMBCK="Q" K X,Y,DIRUT,DTOUT,DUOUT S PSORENW("QFLG")=1
         Q
         ;
DELETE   ;
         K DA,DIK
         S DA=$O(^PS(52.5,"B",PSORENW("OIRXN"),0)),DIK="^PS(52.5,"
         D ^DIK K DIK,DIC
         Q
         ;
CAN      ;
         K REA,DA,MSG
         S REA="C",DA=PSORENW("OIRXN")
         S MSG="Renewed"_$S($G(PSOFDR):" from CPRS",1:"")
         S PSCAN(PSORENW("ORX #"))=DA_"^C"
         D CAN^PSOCAN
         K REA,DA,MSG,PSCAN
         Q
         ;
DIR      ;
         S DIR(0)="Y",DIR("A")="CONTINUE ",DIR("B")="N"
         S DIR("?")="Answer YES to Continue, NO to bypass"
         D ^DIR K DIR
         S:$D(DIRUT)!('Y) PSORENW("DFLG")=1
DIRX     K DIRUT,DTOUT,DUOUT,X,Y
         Q
NEWPT    ;
         S PSOQFLG=0 N PSODFN
         S PSODFN=PSORENW("PSODFN")
         D ^PSOPTPST I PSOQFLG S PSORENW("DFLG")=1,PSOQFLG=0 G NEWPTX
         D PROFILE^PSOREF1
NEWPTX   Q
         ;
EN(PSORENW) --
                 ; Entry Point for Batch Barcode Option
         S PSORENRX=$G(PSOBBC("OIRXN"))
         I $G(PSORENRX) D PSOL^PSSLOCK(PSORENRX) I '$G(PSOMSG) D  K DIR,PSOMSG W
           ! S DIR("A")="Press Return to continue",DIR(0)="E",DIR("?")="Press Re
          turn to continue" D ^DIR K DIR W ! Q
         .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
         .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENRX,0)),"^
          ")
         K PSOMSG,PSOBBCLK S PSOBARCD=1 D PROCESS K PSOBARCD
         D KLIB^PSORENW1
         I $G(PSORENRX),$G(PSOBBCLK) D PSOUL^PSSLOCK(PSORENRX)
         K PSORENRX,PSOBBCLK
         Q
CDOSE    ;Validate Dosage field on Renewal, Copy, Edit
         ;PSOOCPRX must be set to internal Rx number
         Q:'$G(PSOOCPRX)
         N PSOOLP,PSOOKZ
         S PSOOLP="",(PSOOLPF,PSONOSIG)=0 F  S PSOOLP=$O(^PSRX(PSOOCPRX,6,PSOOLP
          )) Q:PSOOLP=""!(PSOOLPF)  I $P($G(^PSRX(PSOOCPRX,6,PSOOLP,0)),"^")["0.
          ." S PSOOLPD=$P($G(^(0)),"^"),PSOOLPF=1
         Q:PSOOLPF
         S PSOOKZ=0
         I $P($G(^PSRX(PSOOCPRX,"SIG")),"^",2) S PSOOLP="" F  S PSOOLP=$O(^PSRX(
          PSOOCPRX,"SIG1",PSOOLP)) Q:PSOOLP=""!(PSOOKZ)  I $G(^PSRX(PSOOCPRX,"SI
          G1",PSOOLP,0))'="" S PSOOKZ=1
         I '$P($G(^PSRX(PSOOCPRX,"SIG")),"^",2),$P($G(^("SIG")),"^")'="" S PSOOK
          Z=1
         I 'PSOOKZ S PSONOSIG=1
         Q
         ;
         ;; ** START NCC REMEDIATION ** 457/RTW
ALERT    ; send an alert to the three approving team members
         S XQADATA=PSCLPAT
         S PSOLAST4=$E($P($G(^DPT(PSCLPAT,0)),"^",9),6,9)
         S XQAARCH=1
         S XQAFLG="D"
         S XQA(PSO1PH)="",XQA(PSO2PH)="",XQA(PSOUSER)=""
         S XQAMSG=$$GET1^DIQ(2,PSCLPAT,.01)_"("_PSOLAST4_")"_": CLOZAPINE OVERRI
          DE RX PROCESSED"
         S XQAID="PSI"_","_PSCLPAT
         D PHGRP^PSOCLO1 M XQA=XMY D SETUP^XQALERT
         W !!,"OVERRIDE ALERTS HAVE BEEN SENT TO THE APPROVING TEAM MEMBERS",!!
         Q
         ; ** END NCC REMEDIATION ** 457/RTW

*****   INDEX OF PSORENW0   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   %            ANQ,ANQ+5,ANQ+9!
   ACOM         CHECK+13!,CHECK+14!,CHECK+19,CHECK+32*,CHECK+39!
   ANQDATA      ANQ,ANQ+3,ANQ+9!
   ANQREM       ANQ+9!
   BBRN         DSPL+9*,PROCESSX+4!
   BBRN1        DSPL+9*,PROCESSX+4!
>> BINGCRT      DSPL+9*
>> BINGRTE      DSPL+9*
   DA           ANQ+6!,ANQ+7*,ANQ+8!,DELETE+1!,DELETE+2*,CAN+1!,CAN+2*,CAN+4
                CAN+6!
   DD           ANQ+5!,ANQ+6!
   DIC          ANQ+5*,ANQ+6!,DELETE+3!
   DIC(0        ANQ+5*
   DIE          ANQ+7*,ANQ+8!
   DIK          DELETE+1!,DELETE+2*,DELETE+3!
   DIR          PROCESSX+2!,CHECK+10!,CHECK+13!,CHECK+14!,RETRY+6!,EDIT+1!
                EDIT+4!,DIR+3!,EN+2!
   DIR("?"      PROCESSX+2*,CHECK+10*,RETRY+6*,EDIT+3*,DIR+2*,EN+2*
   DIR("A"      PROCESSX+2*,CHECK+10*,CHECK+21*,CHECK+36*,RETRY+6*,EDIT+3*
                DIR+1*,EN+2*
   DIR("B"      CHECK+21*,CHECK+36*,EDIT+2*,DIR+1*
   DIR(0        PROCESSX+2*,CHECK+10*,CHECK+21*,CHECK+36*,RETRY+6*,EDIT+2*
                DIR+1*,EN+2*
   DIRUT        CHECK+13!,CHECK+14!,CHECK+22,CHECK+23,CHECK+37,CHECK+38,EDIT+4
                EDITX!,DIR+4,DIRX!
   DLAYGO       ANQ+5*,ANQ+6!
   DO           ANQ+5!,ANQ+6!
   DR           ANQ+6!,ANQ+7*,ANQ+8!
   DRG          CHECK+13~,CHECK+20*,CHECK+21,CHECK+35*,CHECK+36
   DT           FILDATE+5
   DTOUT        PROCESSX+2!,EDITX!,DIRX!
   DUOUT        PROCESSX+2!,CHECK+13!,CHECK+14!,EDITX!,DIRX!
   DUZ          DSPL+4
   DUZ("AG"     EDIT+2
   MSG          CAN+1!,CAN+3*,CAN+6!
   NEWDOSE      DSPL+5!
>> OR0          CHECK+34
>> ORN          PROCESSX+1
>> ORO          ANQ+4
   PHI          PROCESSX+4!
>> POERR        PROCESSX,CHECK+3,CHECK+9,CHECK+27,CHECK+32,RETRY+7
>> POERR("DFLG" PROCESSX+1*
   PRC          PROCESSX+4!
   PS52         ANQ+7~*
   PSCAN        CAN+6!
   PSCAN(       CAN+4*
>> PSCLPAT      ALERT+1,ALERT+2,ALERT+6,ALERT+7
>> PSEXDT       EDIT+2
   PSO1PH       ANQ~*,ANQ+2~,ANQ+3*,ANQ+7,ALERT+5
   PSO2PH       ANQ~*,ANQ+2~,ANQ+3*,ANQ+7,ALERT+5
   PSOBARCD     EN+5*!
>> PSOBBC("OIRXN" 
                EN+1
   PSOBBCLK     PROCESSX*,EN+5!,EN+7,EN+8!
   PSODFN       PROCESS+3,CHECK+1,NEWPT+1~,NEWPT+2*
   PSODRUG      PROCESSX+4!
   PSODRUG("OI" DRUG+4*
   PSODRUG("OIN" 
                DRUG+4*
   PSOEDT       DSPL!,PROCESSX+5!,EDITX*
>> PSOFDR       PROCESS+11,DSPL+1,RETRY+2,RETRY+5,RETRY+7,CAN+3
>> PSOLAST4     ALERT+2*,ALERT+6
   PSOLM        DSPL!,PROCESSX+5!
>> PSOLST(      PROCESSX+1
   PSOMSG       EN+2!,EN+3,EN+5!
>> PSONEW("STATUS" 
                DRUG+10,DRUG+11!
>> PSONOOR      DRUG+8*
   PSONOSIG     CHECK+5~,CHECK+6,CDOSE+4*,CDOSE+9*
   PSOOCPRX     CHECK+5~*,CDOSE+2,CDOSE+4,CDOSE+7,CDOSE+8
   PSOOKZ       CDOSE+3~,CDOSE+6*,CDOSE+7*,CDOSE+8*,CDOSE+9
   PSOOLP       CDOSE+3~,CDOSE+4*,CDOSE+7*
   PSOOLPD      CHECK+5~,CHECK+8,CHECK+9,CDOSE+4*
   PSOOLPF      CHECK+5~,CHECK+6,CHECK+8,CHECK+9,CDOSE+4*,CDOSE+5
>> PSOORRNW     CHECK+25
>> PSOPAR       DSPL+4
   PSOPROV      ANQ+2~,ANQ+3*,ANQ+4*,ANQ+7
>> PSOQFLG      NEWPT+1*,NEWPT+3*
   PSOQUIT      PROCESSX+4!,EDIT+6!
   PSOREA       CHECK+17*,CHECK+18!
   PSOREASN     ANQ~*,ANQ+2~,ANQ+3*,ANQ+7
   PSOREMRK     ANQ~*,ANQ+2~,ANQ+3*,ANQ+7
   PSORENRX     EN+1*,EN+2,EN+4,EN+7,EN+8!
   PSORENW      DSPL+4,DSPL+6,PROCESSX+3,PROCESSX+4!,FILDATE+2,FILDATE+4,EDIT+6
                EN~
   PSORENW("DFLG" 
                PROCESS+4*,PROCESS+7,PROCESS+9,PROCESS+10,DSPL,DSPL+2,DSPL+4
                PROCESSX,PROCESSX+5*,CHECK+2*,CHECK+7*,CHECK+14,CHECK+15*
                CHECK+26*,CHECK+28,CHECK+33*,CHECK+40,CHKDIV+3*,DRUG+7*,RETRY
                RETRY+7*,EDIT+4*,EDIT+5,EDIT+6*,DIR+4*,NEWPT+3*
   PSORENW("DRUG IEN" 
                PROCESS+6,DRUG+2
   PSORENW("ENT" 
                DSPL+5
   PSORENW("FILL DATE" 
                PROCESS+4*,FILDATE+3,FILDATE+5*
   PSORENW("FROM" 
                PROCESSX+5
   PSORENW("IRXN" 
                ANQ+7,FILDATE+1*,FILDATE+6!
   PSORENW("MAIL/WINDOW" 
                PROCESS+5*
   PSORENW("NOO" 
                DRUG+8
   PSORENW("NRX #" 
                DSPL+9,RXN+3*,RETRY,RETRY+1,RETRY+2,RETRY+3,RETRY+4,RETRY+5
                RETRY+8,RETRY+9*
   PSORENW("OIRXN" 
                CHECK+5,CHECK+14,CHECK+20,CHECK+35,DRUG+4,FILDATE+1,DELETE+2
                CAN+2
   PSORENW("OLD FILL DATE" 
                PROCESSX+3
   PSORENW("ORX #" 
                PROCESS+6,CHECK+30,CHECK+31,CHECK+32,RXN+2,RXN+3,RETRY+1
                RETRY+3,RETRY+4,RETRY+5,RETRY+7,CAN+4
   PSORENW("PSODFN" 
                PROCESS+3,CHECK+1,NEWPT+2
   PSORENW("QFLG" 
                DSPL+1*,DSPL+3,PROCESSX+5*,EDITX*
   PSORENW("RX0" 
                CHECK+2,CHECK+3,CHECK+8,CHECK+9,CHECK+16,CHECK+26,CHECK+27
                CHKDIV+2
   PSORENW("RX2" 
                CHKDIV+1,CHKDIV+2
   PSORENW("RX3" 
                FILDATE+3
   PSORENW("STA" 
                CHECK+17
   PSORENW("STATUS" 
                DRUG+10*
   PSORENWD     DRUG+2*,DRUG+11!
>> PSORERR      PROCESSX*
   PSORNALL     EDIT+6*!
>> PSORNSPD     CHECK+10,CHECK+11
>> PSORNW("FILL DATE" 
                PROCESS+4,FILDATE+5
>> PSORNW("MAIL/WINDOW" 
                PROCESS+5
   PSORWRIT     PROCESSX~
>> PSORX("BAR CODE" 
                PROCESS+3,CHECK+1
>> PSORX("CLINIC" 
                PROCESSX+4!
>> PSORX("DFLG" PROCESS+9,PROCESSX,DRUG+3,DRUG+5*,DRUG+7
>> PSORX("FILL DATE" 
                FILDATE+5*
>> PSORX("FN"   DSPL+2,DSPL+3,PROCESSX+4!,EDIT+6!,EDIT+7
>> PSORX("INTERVENE" 
                DRUG+9!
>> PSORX("PROVIDER NAME" 
                PROCESSX+4!
   PSOS         CHECK+13~*,CHECK+14*
>> PSOSD        CHECK+14
>> PSOSD(       CHECK+14
>> PSOSITE      CHKDIV+1
   PSOSTAT      CHECK+17*,CHECK+18!
>> PSOSYS       CHKDIV+3,CHKDIV+4
   PSOUSER      ANQ~*,ANQ+2~,ALERT+5
>> PSOWRIT      PROCESSX*
   PSOX         CHECK+13*,CHECK+14*,CHECK+28!,RXN+1!,RXN+2*,RXN+3,RETRY+8*
                RETRY+9,RXNX!
   PSOY         CHECK+13*,CHECK+14*,CHECK+17,CHECK+25,CHECK+28!,DRUG+1!,DRUG+2*
                DRUG+3,DRUG+11!
   PSOY(0       DRUG+2*
   REA          CAN+1!,CAN+2*,CAN+6!
>> SPEED        CHECK+32
>> VALMBCK      PROCESSX+2*,CHECK+3*,CHECK+9*,CHECK+27*,CHECK+32*,RETRY+7*
                EDITX*
>> VALMSG       CHECK+3*,CHECK+9*,CHECK+27*,CHECK+32*,DRUG+5*,RETRY+2*,RETRY+5*
                RETRY+7*
   X            ANQ+5*,ANQ+9!,EDIT+1!,EDITX!,DIRX!
>> XMY          ALERT+8
>> XQA          ALERT+8*
>> XQA(         ALERT+5*
>> XQAARCH      ALERT+3*
>> XQADATA      ALERT+1*
>> XQAFLG       ALERT+4*
>> XQAID        ALERT+7*
>> XQAMSG       ALERT+6*
   Y            ANQ+7,ANQ+9!,CHECK+22,CHECK+37,FILDATE+5*!,EDIT+1!,EDIT+6
                EDITX!,DIR+4,DIRX!

Global Variables  ( * Changed  ! Killed)
   ^DD("DD"            FILDATE+5
   ^DPT(               ALERT+2
   ^PS(50.7            DRUG+4
   ^PS(52.5            DELETE+2
   ^PS(52.52           ANQ
   ^PS(59              CHKDIV+2
   ^PSDRUG(            PROCESS+6,CHECK+20,CHECK+35,DRUG+2,DRUG+3
   ^PSRX(              DSPL+9,CHECK+20,CHECK+35,DRUG+4,EN+4,CDOSE+4,CDOSE+7
                       CDOSE+8
   ^PSRX("B"           DSPL+9,RETRY
   ^XUSEC("PSORPH"     DSPL+4

Naked Globals
   ^("OR1"      DRUG+4
   ^("SIG"      CDOSE+8
   ^(0          CDOSE+4

Cache Objects
   NONE

Marked Items
   NONE

Label References
   ALERT        ANQ+10
   ANQ          ANQ
   CAN          DSPL+8
   CDOSE        CHECK+5
   CHECK        PROCESS+7
   CHECKX       CHECK+1,CHECK+6,CHECK+28,CHECK+40
   CHKDIV       CHECK+40
   CHKDIVX      CHKDIV+1,CHKDIV+3
   DIR          CHKDIV+4
   DRUG         PROCESS+9
   DSPL         DSPL+3,DSPL+5
   EDIT         DSPL+1
   EDITX        EDIT+5
   FILDATE      PROCESS+8
   NEWPT        PROCESS+3
   NEWPTX       NEWPT+3
   PROCESS      EN+5
   PROCESSX     PROCESS+7,PROCESS+9,PROCESS+10,DSPL,DSPL+2,DSPL+4
   RETRY        RETRY
   RXN          PROCESS+10

External References
   NOW^%DTC            ANQ
   FILE^DICN           ANQ+6
   ^DIE                ANQ+8
   ^DIK                DELETE+3
   $$GET1^DIQ          ALERT+6
   ^DIR                PROCESSX+2,CHECK+10,CHECK+22,CHECK+37,RETRY+6,EDIT+4
                       DIR+3,EN+2
   CAN^PSOCAN          CAN+5
   NOOR^PSOCAN4        CHECK+23,CHECK+38
   PHGRP^PSOCLO1       ALERT+8
   DOSCK^PSODOSUT      DRUG+7
   POST^PSODRG         DRUG+7
   SET^PSODRG          DRUG+6
   DCORD^PSONEW2       DSPL+8
   DE^PSOORFI2         CHECK+23,CHECK+38
   EN^PSOORNE4         EDIT+6
   VER1^PSOORNE4       DSPL+4
   ^PSOPTPST           NEWPT+3
   PROFILE^PSOREF1     NEWPT+4
   INST2^PSORENW       PROCESS+2
   ^PSORENW1           PROCESS+1
   KLIB^PSORENW1       EN+6
   OERR^PSORENW1       PROCESS+11
   STOP^PSORENW1       PROCESS+11
   DSPLY^PSORENW3      DSPL
   INIT^PSORENW3       EDIT+6
   EN^PSORN52          DSPL+6
   CHKPRV^PSOUTIL      CHECK+42
   NEXT^PSOUTIL        FILDATE+2
   RENFDT^PSOUTIL      FILDATE+4
   RNPSOSD^PSOUTIL     DSPL+7
   STATUS^PSOUTIL      CHECK+18
   SUSDATEK^PSOUTIL    PROCESSX+3
   CLEAN^PSOVER1       PROCESSX+1,PROCESSX+6
   PSOL^PSSLOCK        EN+2
   PSOUL^PSSLOCK       PROCESSX+1,EN+7
   FULL^VALM1          EDIT+6
   SETUP^XQALERT       ALERT+8

*****   END   *****


|dd52.52 * *  7 Lines,  184 Bytes, Checksum:      Jul 01, 2016@06:56:32 page 8
              118 bytes in comments
|dd52.52 ;Partial DD of the CLOZAPINE PRESCRIPTION OVERRIDES file.
4        ; REASON FOR OVERRIDE
         Q
5        ; COMMENTS
         K:$L(X)>200!($L(X)<5)!(X?." ") X
6        ; SECOND APPROVING TEAM MEMBER
         Q

*****   INDEX OF |dd52.52   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   X            5+1!

Global Variables  ( * Changed  ! Killed)
   NONE

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   NONE

*****   END   *****


|dd52.54 * *  7 Lines,  254 Bytes, Checksum:      Jul 01, 2016@06:56:32 page 9
              109 bytes in comments
|dd52.54 ;DD of the CLOZAPINE OVERRIDE REASONS file.
.01      ; OVERRIDE REASON
         K:$L(X)>100!($L(X)<3)!'(X'?1P.E) X
.01XRF1S ; SET LOGIC FOR 'B' XREF
         S ^PS(52.54,"B",$E(X,1,30),DA)=""
.01XRF1K ; KILL LOGIC FOR 'B' XREF
         K ^PS(52.54,"B",$E(X,1,30),DA)

*****   INDEX OF |dd52.54   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
>> DA           .01XRF1S+1,.01XRF1K+1
   X            .01+1!,.01XRF1S+1,.01XRF1K+1

Global Variables  ( * Changed  ! Killed)
   ^PS(52.54           .01XRF1S+1*,.01XRF1K+1!

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   NONE

*****   END   *****


|opt     * *  15 Lines,  531 Bytes, Checksum:     Jul 01, 2016@06:56:32 page 10
              401 bytes in comments
|opt     ; 'Build file' Options.
         ;
2911820  ; PSOL MANAGER - Clozapine Pharmacy Manager (menu) - Locked by PSOLOCKC
          LOZ
2911816  ; PSOL REGISTER PATIENT - Register Clozapine Patient (run routine)
         ; ROUTINE
         D REG^PSOCLUTL
4740     ; PSOLAB LIST - Display Lab Tests and Results (run routine)
         ; ROUTINE
         D ^PSORXLAB
4741     ; PSOLIST OVERRIDES - List of Override Prescriptions (run routine)
         ; ROUTINE
         D ^PSOCLOLS
2911821  ; PSOL EDIT - Edit Data for a Patient in the Clozapine Program (run rou
          tine)
         ; ROUTINE
         D AGAIN^PSOCLUTL

*****   INDEX OF |opt   *****


Local Variables      Line Occurrences   ( >> not killed explicitly)
                                        ( * Changed  ! Killed  ~ Newed)
   NONE

Global Variables  ( * Changed  ! Killed)
   NONE

Naked Globals
   NONE

Cache Objects
   NONE

Marked Items
   NONE

Label References
   NONE

External References
   ^PSOCLOLS           4741+2
   AGAIN^PSOCLUTL      2911821+2
   REG^PSOCLUTL        2911816+2
   ^PSORXLAB           4740+2

*****   END   *****


--- CROSS-REFERENCING ALL ROUTINES ---

*****   Cross Reference of all Routines   *****   Jul 01, 2016@06:56:32 page 11

Local Variables    Routines   ( >> not killed explicitly)
                              ( * Changed  ! Killed  ~ Newed)
   %            PSOCLO1*~,PSOCLUTL*!,PSON52*!~,PSORENW0!
   %DT          PSOCLO1~,PSON52!
>> %H           PSOCLUTL*
   %Y           PSOCLUTL!
   ACOM         PSORENW0*!
   ACTION       PSON52*~
   ANQ          PSOCLO1~
   ANQ(         PSOCLO1*
   ANQ(""       PSOCLO1
   ANQ(1        PSOCLO1*
   ANQD         PSOCLO1*~
   ANQD(        PSOCLO1*
   ANQD(1       PSOCLO1*
   ANQDATA      PSOCLO1*!,PSON52!,PSORENW0!
   ANQJ         PSOCLO1*~
   ANQNO        PSOCLO1!
   ANQRE        PSOCLO1*~
   ANQREM       PSON52!,PSORENW0!
   ANQRTN       PSODRG*!
   ANQX         PSOCLO1*!,PSOCLO1*,PSOCLUTL*,PSODRG*!
>> ANXQ         PSOCLO1*
   AOC          PSODRG*~
>> BBFLG        PSON52*
   BBRN         PSORENW0*!
   BBRN1        PSORENW0*!
>> BINGCRT      PSON52*,PSORENW0*
>> BINGRTE      PSON52*,PSORENW0*
   C            PSOCLUTL!
>> CLOZ         PSOCLUTL
   CLOZFLG      PSOCLO1*!,PSODRG
   CLOZPAT      PSOCLO1*,PSODRG!,PSON52
   CNT          PSODRG*!,PSON52*~
>> COPY         PSODRG
   CROCPFLG     PSODRG*!~
   D            PSOCLUTL!,PSODRG*!,PSON52*!
   D0           PSOCLUTL!
   DA           PSOCLO1*!,PSOCLUTL*!,PSODRG*!,PSON52*!,PSORENW0*!,|dd52.54
   DAI          PSON52*!
   DATA         PSOCLO1~
   DD           PSON52!,PSORENW0!
>> DEA          PSON52*
>> DEA("CS"     PSON52
   DFN          PSOCLO1*,PSODRG*!
   DI           PSOCLUTL!
   DIC          PSOCLO1*!,PSOCLUTL*!,PSODRG*!,PSON52*!,PSORENW0*!
   DIC("A"      PSOCLO1*,PSOCLUTL*
   DIC("S"      PSOCLO1*,PSOCLUTL*,PSODRG*
   DIC("T"      PSODRG*
   DIC(0        PSOCLO1*,PSOCLUTL*,PSODRG*,PSON52*,PSORENW0*
   DIE          PSOCLUTL*!,PSODRG*!,PSON52*!,PSORENW0*!
   DIK          PSOCLO1*!,PSON52*!,PSORENW0*!
   DIR          PSOCLO1!~,PSOCLUTL!,PSODRG!~,PSORENW0!
   DIR("?"      PSOCLO1*,PSODRG*,PSORENW0*
   DIR("A"      PSOCLO1*,PSOCLUTL*,PSODRG*,PSORENW0*
   DIR("B"      PSOCLO1*,PSOCLUTL*,PSODRG*,PSORENW0*
   DIR(0        PSOCLO1*,PSOCLUTL*,PSODRG*,PSORENW0*
   DIROUT       PSOCLO1!
   DIRUT        PSOCLO1!~,PSOCLUTL!,PSODRG!,PSONEW1!,PSORENW0!
   DIWF         PSODRG*!
   DIWL         PSODRG*!
   DIWR         PSODRG*!
   DLAYGO       PSOCLUTL*!,PSON52*!,PSORENW0*!
   DO           PSON52!,PSORENW0!
   DQ           PSOCLUTL!
   DR           PSOCLUTL*!,PSODRG*!,PSON52*!,PSORENW0*!
   DRG          PSODRG~,PSORENW0*~
   DT           PSOCLO1,PSOCLUTL,PSON52,PSORENW0
   DTIME        PSODRG
   DTOUT        PSOCLO1!~,PSOCLUTL!,PSODRG*!~,PSORENW0!
   DTTM         PSON52*~
   DUOUT        PSOCLO1!~,PSOCLUTL!,PSODRG!~,PSORENW0!
>> DUPRX0       PSOCLO1
   DUZ          PSOCLO1,PSOCLUTL,PSON52,PSORENW0
   DUZ("AG"     PSONEW1,PSORENW0
   DUZ(2        PSOCLUTL
   ERR          PSOCLO1~
   FIRST        PSOCLO1*~
   FLG          PSOCLO1!~
   GOC          PSODRG*~
   HLDSIG       PSON52!
   I            PSOCLO1~,PSODRG*!,PSON52*
   IOSL         PSODRG
   IT           PSODRG!
   J            PSOCLO1~
>> JADOVER      PSOCLUTL*
   LAB          PSODRG!
   LAB(         PSODRG*
   LAB("BAD TEST" 
                PSODRG*
   LAB("NOT"    PSODRG*
   LABT         PSODRG*!
   LAST         PSOCLO1*~
   LIST         PSODRG*~
   LSTFOUR      PSOCLO1*~,PSOCLUTL*
   MNTRX        PSON52~
   MSG          PSOCLO1~,PSORENW0*!
   MSG(1        PSOCLO1*
   MSGNUM       PSOCLO1*~
   NAME         PSOCLO1*~
>> ND0          PSOCLO1
   NDC          PSODRG*~
   NDF          PSODRG~
   NEWDOSE      PSORENW0!
   NFI          PSODRG*!
   NOW          PSOCLO1~
   NUM          PSOCLO1*~
   OCNT         PSON52*~
   OI           PSODRG*~
   OIR          PSODRG*~
   OLENT        PSON52!
>> OR0          PSODRG,PSON52,PSORENW0
>> ORN          PSORENW0
>> ORO          PSOCLO1,PSORENW0
   OTHDOS       PSON52!
>> P(5          PSODRG*!
   PAD          PSOCLO1*~
   PHI          PSORENW0!
>> POERR        PSODRG,PSORENW0
>> POERR("DFLG" PSORENW0*
   PRC          PSORENW0!
   PREF         PSOCLO1*~
   PS52         PSON52*~,PSORENW0*~
   PSCAN        PSORENW0!
   PSCAN(       PSODRG,PSORENW0*
   PSCAN(0      PSODRG
>> PSCLOZ       PSOCLO1*,PSOCLUTL
>> PSCLPAT      PSOCLO1*,PSORENW0
>> PSEXDT       PSORENW0
>> PSJCNT       PSOCLO1*
>> PSJORDER("PSJORN" 
                PSOCLO1*
>> PSJORN       PSOCLO1*
>> PSLAST7      PSOCLO1*
   PSMSGTXT     PSOCLO1*~
   PSO          PSOCLUTL!
   PSO1         PSOCLO1*~,PSOCLUTL*!
   PSO1PH       PSON52*~,PSORENW0*~
   PSO2         PSOCLO1*~,PSOCLUTL*!
   PSO2PH       PSON52*~,PSORENW0*~
   PSO3         PSOCLUTL*!
   PSO4         PSOCLO1~,PSOCLUTL*!
   PSOANSQ      PSON52!
   PSOANSQ("CV" PSON52
   PSOANSQ("HNC" 
                PSON52
   PSOANSQ("MST" 
                PSON52
   PSOANSQ("PGW" 
                PSON52
   PSOANSQ("RAD" 
                PSON52
   PSOANSQ("SC" PSON52
   PSOANSQ("SHAD" 
                PSON52
   PSOANSQ("VEH" 
                PSON52
   PSOANSQD     PSON52!
   PSOBARCD     PSORENW0*!
>> PSOBBC("OIRXN" 
                PSORENW0
   PSOBBCLK     PSORENW0*!
   PSOC         PSOCLUTL!
   PSOCD        PSOCLO1*~
   PSOCONT      PSODRG*~
>> PSOCOU       PSON52
>> PSOCOUU      PSON52
>> PSOCSP("# OF REFILLS" 
                PSON52
>> PSOCSP("DAYS SUPPLY" 
                PSON52
>> PSOCSP("DOSE ORDERED" 
                PSON52
>> PSOCSP("DOSE" 
                PSON52
>> PSOCSP("ISSUE DATE" 
                PSON52
>> PSOCSP("NAME" 
                PSON52
>> PSOCSP("QTY" PSON52
   PSODFN       PSODRG,PSON52,PSONEW1,PSORENW0*~
>> PSODGCK      PSODRG
>> PSODGCKX     PSODRG
   PSODIR       PSODRG!
   PSODIR("FIELD" 
                PSODRG
   PSODIR("FLD" PSODRG*
   PSODLQT      PSODRG!
   PSODOSD      PSODRG!
   PSODRG       PSODRG!
   PSODRG("QFLG" 
                PSODRG*
   PSODRUG      PSORENW0!
   PSODRUG("BAD" 
                PSODRG!
   PSODRUG("CLN" 
                PSODRG*
   PSODRUG("COST" 
                PSODRG*
   PSODRUG("DAW" 
                PSODRG*!
   PSODRUG("DEA" 
                PSODRG*,PSON52
   PSODRUG("EXPIRATION DATE" 
                PSODRG*
   PSODRUG("IEN" 
                PSODRG*,PSON52
   PSODRUG("MAXDOSE" 
                PSODRG*
   PSODRUG("NAME" 
                PSODRG*,PSON52
   PSODRUG("NDC" 
                PSODRG*!
   PSODRUG("NDF" 
                PSODRG*
   PSODRUG("OI" PSODRG*,PSON52,PSORENW0*
   PSODRUG("OIN" 
                PSODRG*,PSORENW0*
   PSODRUG("SIG" 
                PSODRG*
   PSODRUG("STKLVL" 
                PSODRG*
   PSODRUG("TRADE NAME" 
                PSODRG*!
   PSODRUG("UNIT" 
                PSODRG*
   PSODRUG("VA CLASS" 
                PSODRG*
>> PSOEDIT      PSODRG
   PSOEDT       PSORENW0*!
   PSOERX       PSON52*~
>> PSOFDR       PSORENW0
   PSOFINFL     PSON52!
>> PSOFL        PSOCLO1*
>> PSOID        PSON52
   PSOINSFL     PSON52!
>> PSOLAST4     PSORENW0*
   PSOLM        PSORENW0!
   PSOLN        PSOCLUTL!
>> PSOLST(      PSORENW0
   PSOMSG       PSORENW0!
   PSON52       PSON52*!
   PSON52(      PSON52*
   PSON52("QFLG" 
                PSON52*
   PSONAME      PSOCLO1*~,PSOCLUTL*!
>> PSONCROC     PSODRG
>> PSONEW       PSONEW1
>> PSONEW("# OF REFILLS" 
                PSON52,PSONEW1*
>> PSONEW("CLERK CODE" 
                PSON52*
>> PSONEW("DAYS SUPPLY" 
                PSON52,PSONEW1*
>> PSONEW("DFLG" 
                PSODRG*,PSON52,PSONEW1*
>> PSONEW("DOSE ORDERED" 
                PSON52,PSONEW1*
>> PSONEW("DOSE" 
                PSON52,PSONEW1*
>> PSONEW("DURATION" 
                PSONEW1*
>> PSONEW("ENT" PSON52!,PSONEW1*
>> PSONEW("FIELD" 
                PSODRG*,PSONEW1*
>> PSONEW("FLD" PSODRG,PSONEW1*
>> PSONEW("INS" PSON52!
>> PSONEW("ISSUE DATE" 
                PSON52
>> PSONEW("OLD VAL" 
                PSODRG*!
>> PSONEW("PATIENT STATUS" 
                PSON52
>> PSONEW("QFLG" 
                PSONEW1
>> PSONEW("QTY" PSON52,PSONEW1*
>> PSONEW("REMARKS" 
                PSON52*
>> PSONEW("SAND" 
                PSOCLO1*!
>> PSONEW("STATUS" 
                PSORENW0!
>> PSONEW("STOP DATE" 
                PSON52
   PSONEW1      PSONEW1*!
   PSONO        PSOCLUTL!
   PSONOAL      PSODRG*!
>> PSONOOR      PSORENW0*
   PSONOSIG     PSORENW0*~
>> PSONV        PSODRG
   PSOOCPRX     PSORENW0*~
   PSOOKZ       PSORENW0*~
   PSOOLP       PSORENW0*~
   PSOOLPD      PSORENW0*~
   PSOOLPF      PSORENW0*~
>> PSOORRNW     PSORENW0
>> PSOPAR       PSON52,PSONEW1,PSORENW0
   PSOPRC       PSON52!
   PSOPROV      PSORENW0*~
>> PSOQFLG      PSORENW0*
   PSOQUIT      PSODRG!,PSORENW0!
   PSOREA       PSORENW0*!
   PSOREASN     PSON52*~,PSORENW0*~
>> PSOREINS     PSODRG
   PSOREMRK     PSON52*~,PSORENW0*~
   PSORENRX     PSORENW0*!
   PSORENW      PSORENW0!~
   PSORENW("DFLG" 
                PSODRG,PSORENW0*
   PSORENW("DRUG IEN" 
                PSORENW0
   PSORENW("ENT" 
                PSORENW0
   PSORENW("FILL DATE" 
                PSORENW0*
   PSORENW("FROM" 
                PSORENW0
   PSORENW("IRXN" 
                PSORENW0*!
   PSORENW("MAIL/WINDOW" 
                PSORENW0*
   PSORENW("NOO" 
                PSORENW0
   PSORENW("NRX #" 
                PSORENW0*
   PSORENW("OIRXN" 
                PSORENW0
   PSORENW("OLD FILL DATE" 
                PSORENW0
   PSORENW("ORX #" 
                PSORENW0
   PSORENW("PSODFN" 
                PSORENW0
   PSORENW("QFLG" 
                PSORENW0*
   PSORENW("RX0" 
                PSORENW0
   PSORENW("RX2" 
                PSORENW0
   PSORENW("RX3" 
                PSORENW0
   PSORENW("STA" 
                PSORENW0
   PSORENW("STATUS" 
                PSORENW0*
   PSORENWD     PSORENW0*!
>> PSORERR      PSORENW0*
   PSORNALL     PSORENW0*!
>> PSORNSPD     PSORENW0
>> PSORNW("FILL DATE" 
                PSORENW0
>> PSORNW("MAIL/WINDOW" 
                PSORENW0
   PSORWRIT     PSORENW0~
>> PSORX("BAR CODE" 
                PSORENW0
>> PSORX("CLINIC" 
                PSORENW0!
>> PSORX("DFLG" PSODRG*!,PSORENW0*
>> PSORX("EDIT" PSODRG
>> PSORX("FILL DATE" 
                PSORENW0*
>> PSORX("FN"   PSORENW0!
>> PSORX("INTERVENE" 
                PSODRG*!,PSORENW0!
>> PSORX("MAIL/WINDOW" 
                PSON52
>> PSORX("PATIENT STATUS" 
                PSON52
>> PSORX("PHARM" 
                PSON52!
>> PSORX("PROVIDER NAME" 
                PSORENW0!
>> PSORX("PSOL" PSON52*
>> PSORX("VERIFY" 
                PSON52
>> PSORXED      PSODRG
>> PSORXED("DFLG" 
                PSODRG*
>> PSORXED("ENT" 
                PSON52!
>> PSORXED("FLD" 
                PSODRG*
>> PSORXED("INS" 
                PSON52!
>> PSORXED("IRXN" 
                PSODRG
   PSOS         PSORENW0*~
   PSOSCFLD     PSON52*!~
>> PSOSCP       PSON52
>> PSOSD        PSODRG,PSORENW0
>> PSOSD(       PSORENW0
>> PSOSIGFL     PSON52
>> PSOSITE      PSODRG,PSON52,PSORENW0
>> PSOSPRNW     PSODRG
   PSOSTAT      PSORENW0*!
>> PSOSYS       PSORENW0
   PSOT         PSOCLUTL!
   PSOTFIN      PSON52*~
   PSOTITRX     PSON52!
>> PSOTRN       PSODRG
   PSOUSER      PSON52*~,PSORENW0*~
>> PSOWRIT      PSORENW0*
   PSOX         PSON52~,PSORENW0*!
   PSOX("# OF REFILLS" 
                PSON52
   PSOX("55 IEN" 
                PSON52*
   PSOX("CHCS NUMBER" 
                PSON52
   PSOX("CONJUNCTION" 
                PSON52
   PSOX("COPIES" 
                PSON52*
   PSOX("CS"    PSON52*
   PSOX("DAYS SUPPLY" 
                PSON52
   PSOX("DISPENSED DATE" 
                PSON52*
   PSOX("DOSE ORDERED" 
                PSON52
   PSOX("DOSE"  PSON52
   PSOX("DURATION" 
                PSON52
   PSOX("ENT"   PSON52
   PSOX("EXTERNAL SYSTEM" 
                PSON52
   PSOX("FILL DATE" 
                PSON52
   PSOX("INS"   PSON52!
   PSOX("IRXN"  PSON52*,PSON52
   PSOX("ISSUE DATE" 
                PSON52*
   PSOX("LOGIN DATE" 
                PSON52*
   PSOX("NEWCOPAY" 
                PSON52!
   PSOX("NEXT POSSIBLE REFILL" 
                PSON52*
   PSOX("NOPSDRPH" 
                PSON52*!
   PSOX("NOUN"  PSON52
   PSOX("ODOSE" PSON52
   PSOX("PHARMACIST" 
                PSON52*
   PSOX("ROUTE" PSON52
   PSOX("RX #"  PSON52
   PSOX("SCHEDULE" 
                PSON52
   PSOX("SIG"   PSON52
   PSOX("SINS"  PSON52
   PSOX("STATUS" 
                PSON52*
   PSOX("STOP DATE" 
                PSON52*
   PSOX("TYPE OF RX" 
                PSON52*
   PSOX("UNITS" PSON52
   PSOX("VERB"  PSON52
   PSOX1        PSODRG*!,PSON52*!
   PSOX2        PSON52*!
   PSOY         PSODRG*!,PSON52*!,PSORENW0*!
   PSOY(0       PSODRG*,PSORENW0*
   PSOYS        PSOCLO1*~
>> PSPROVID     PSOCLO1*
   PSREASON     PSOCLO1*~
   PSREG        PSOCLO1*~
>> PSREMARK     PSOCLO1*
>> PSSPHARM     PSOCLO1*
   PSTYPE       PSOCLO1*~
   PSZZQUIT     PSODRG*!
   PTR          PSODRG~
   R            PSOCLUTL!
   REA          PSODRG,PSORENW0*!
   REG          PSOCLO1*~
   RFL          PSODRG~
   RTE          PSON52!
   RX           PSODRG~
>> RXFL(        PSON52*
   RXIEN        PSODRG*~
   RXSTA        PSODRG*~
   SCH          PSON52!
   SIG          PSODRG~,PSON52!
   SIG(         PSON52
   SIG(0        PSONEW1
>> SIGOK        PSON52,PSONEW1*
   SITE         PSOCLO1*~
>> SPEED        PSORENW0
   SSN          PSOCLO1*~,PSOCLUTL*
   SSNVAERR     PSOCLUTL!
   STAT         PSOCLO1~,PSODRG~
   TITRX        PSON52~
   TMP1         PSOCLO1*~
   TMP2         PSOCLO1*~
   TP           PSON52*!
   U            PSOCLO1,PSOCLUTL,PSODRG
>> VALMBCK      PSORENW0*
>> VALMSG       PSORENW0*
   VAP          PSODRG~
   X            PSOCLO1*~,PSOCLUTL!,PSODRG*!,PSON52*!,PSORENW0*!,|dd52.52!
                |dd52.54!
   X1           PSOCLO1*~,PSON52*
>> X2           PSOCLO1*,PSON52*
   X2XML        PSOCLO1~
   XDUZ         PSOCLO1*!
   XMDUN        PSOCLUTL*!
   XMDUZ        PSOCLUTL*!
   XMER         PSOCLUTL!
>> XMFROM       PSOCLO1*
>> XMMG         PSOCLO1
   XMREC        PSOCLUTL!
>> XMRG         PSOCLO1*
   XMSUB        PSOCLO1*~,PSOCLUTL*!
   XMTEXT       PSOCLO1*~,PSOCLUTL*!
   XMY          PSOCLUTL!,PSORENW0
   XMY("G.CLOZAPINE ROLL-UP" 
                PSOCLO1*
   XMY("G.CLOZAPINE ROLL-UP@FORUM.DNS   " 
                PSOCLUTL*
   XMY("G.RUCLDEM@FO-DALLAS.MED.DNS   " 
                PSOCLO1*
   XMZ          PSOCLO1,PSOCLUTL!
>> XQA          PSORENW0*
>> XQA(         PSORENW0*
>> XQAARCH      PSORENW0*
>> XQADATA      PSORENW0*
>> XQAFLG       PSORENW0*
>> XQAID        PSORENW0*
>> XQAMSG       PSORENW0*
>> XQDATE       PSOCLO1*
>> XQY0         PSOCLO1
   XRG          PSOCLUTL!
>> XRT0         PSON52
>> XRTL         PSON52
>> XRTN         PSON52*
   XX           PSON52*~
   Y            PSOCLO1*~,PSOCLUTL!,PSODRG*!,PSON52!,PSONEW1,PSORENW0*!
   Y(0          PSOCLO1,PSODRG
   YSCLANS      PSOCLO1*~
   YSCLDAT      PSOCLO1*~
   YSCLDATA     PSOCLUTL!
   YSCLDATA(1   PSOCLUTL*
   YSCLDFN      PSOCLO1~
   YSCLFRQ      PSOCLO1~
   YSCLREG      PSOCLO1~
   ZDGDG        PSODRG!
   ZTHER        PSODRG!
   ZX           PSODRG*!

Global Variables
   ^%ZOSF("PROD"       PSOCLO1
   ^%ZOSF("TEST"       PSODRG
   ^%ZOSF("UCI"        PSOCLO1
   ^DD("DD"            PSOCLO1,PSORENW0
   ^DD("DILOCKTM"      PSOCLUTL,PSON52
   ^DD(55              PSOCLUTL
   ^DPT(               PSOCLO1,PSOCLUTL,PSORENW0
   ^PS(50.7            PSODRG,PSORENW0
   ^PS(52.5            PSORENW0
   ^PS(52.52           PSON52,PSORENW0
   ^PS(52.54           |dd52.54*!
   ^PS(53              PSON52
   ^PS(55              PSOCLO1,PSOCLUTL,PSON52*,PSONEW1
   ^PS(59              PSORENW0
   ^PSDRUG(            PSODRG,PSORENW0
   ^PSDRUG("ACLOZ"     PSON52
   ^PSRX(              PSON52*,PSON52*,PSORENW0
   ^PSRX("ACP"         PSON52*
   ^PSRX("B"           PSON52,PSORENW0
   ^TMP("CLOZFLG"      PSOCLO1*,PSONEW1!
   ^TMP("PSO"          PSOCLUTL!
   ^TMP("PSODAI"       PSON52!
   ^TMP("PSODAOC"      PSODRG*!
   ^TMP("PSODGI"       PSON52!
   ^TMP("PSODGS"       PSON52!
   ^TMP("PSODOSF"      PSON52!
   ^TMP("PSORXDC"      PSODRG!
   ^TMP("PSOSER"       PSON52!
   ^TMP("PSOSERS"      PSON52!
   ^TMP("PSOTDD"       PSON52!
   ^TMP("XQADUZ"       PSOCLO1*
   ^TMP($J             PSOCLO1!,PSOCLUTL!,PSODRG*!
   ^UTILITY($J         PSODRG!
   ^VA(200             PSOCLO1,PSOCLUTL
   ^XTMP("ORRDI"       PSODRG
   ^XTMP("PSJ CLOZ"    PSOCLO1*
   ^XUSEC("PSDRPH"     PSON52
   ^XUSEC("PSOLOCKCLOZ"PSOCLO1
   ^XUSEC("PSORPH"     PSON52,PSORENW0
   ^XUSEC("YSCL AUTHORIZED"
                       PSOCLO1
   ^YSCL(603.01        PSOCLO1,PSOCLUTL

Naked Globals
   ^(           PSOCLO1,PSOCLUTL
   ^("IB"       PSON52
   ^("ND"       PSODRG
   ^("OR1"      PSORENW0
   ^("SAND"     PSOCLUTL
   ^("SIG"      PSORENW0
   ^(0          PSOCLUTL,PSODRG,PSON52*,PSORENW0
   ^(2          PSODRG,PSON52

Cache Objects
   NONE

Marked Items
   $T(          PSON52
   $T(@(3)      PSOCLO1
   $T(DD+PSOX1  PSON52

Routine             Invokes:
   PSOCLO1      C^%DTC,NOW^%DTC,DIC,YN^DICN,DIK,DIR,MSG1^PSJCLOZ,MSG10^PSJCLOZ
                MSG3^PSJCLOZ,MSG4^PSJCLOZ,MSG5^PSJCLOZ,MSG6^PSJCLOZ
                MSG9^PSJCLOZ,NUMBER1^PSOCLUTL,$$SITE^VASITE,XMD,YSCLSERV
                $$CL^YSCLTST2,$$OVERRIDE^YSCLTST2,CL1^YSCLTST2
   PSOCLUTL     YMD^%DTC,DIC,DIE,DIR,PROVCHK^PSJCLOZ,EN^PSOHLUP,XMD
   PSODRG       MIX^DIC1,DIE,$$GET1^DIQ,DIR,DIWP,$$AOC^OROCAPI,$$DOC^OROCAPI
                $$GOC^OROCAPI,$$OITM^ORX8,$$RXRLDT^PSOBPSUT,$$STATUS^PSOBPSUT
                PSOBUILD,CK^PSOCROC,HD^PSODDPR2,DATACK^PSODDPRE,PSODGAL1
                JUMP^PSODIR1,$$GETNDC^PSONDCUT,NDCEDT^PSONDCUT,TD^PSONFI
                ALLERGY^PSOORUT2,$$FIND^PSOREJUT,PSORXI,DUPINV^PSORXI
                EN1^PSORXI,PRFLP^PSOUTL,$$PROMPT^PSSDIN,EN^PSSDIN,IN^PSSHRQ2
                $$GETNDC^PSSNDCUT,DEM^VADPT
   PSON52       C^%DTC,NOW^%DTC,T0^%ZOSV,T1^%ZOSV,FILE^DICN,DIE,IX1^DIK
                $$GET1^DIQ,$$SWSTAT^IBBAPI,$$SUBSCRIB^ORDEA,ECMESND^PSOBPSU1
                RXACT^PSOBPSU2,$$STATUS^PSOBPSUT,$$SUBMIT^PSOBPSUT
                $$TECH2^PSODGDGP,ICD^PSODIAG,$$GETNDC^PSONDCUT,NOOR^PSONEW
                GACT^PSOPFSU0
                $$PSOET^PSOREJP3,$$HDLG^PSOREJU1,$$FIND^PSOREJUT,ALERT^PSORENW0
                BBRX^PSORN52C,ORC^PSORN52C,SUS^PSORXL,$$DS^PSSDSAPI
                PSOUL^PSSLOCK,SAVNDC^PSSNDCUT,$$FMTE^XLFDT,YSCLTST6
   PSONEW1      EN^PSODIAG,DOSE^PSODIR,INS^PSODIR,PROV^PSODIR,SINS^PSODIR
                COPIES^PSODIR1,DAYS^PSODIR1,PTSTAT^PSODIR1,QTY^PSODIR1
                REFILL^PSODIR1,CLERK^PSODIR2,CLINIC^PSODIR2,EXP^PSODIR2
                FILLDT^PSODIR2,ISSDT^PSODIR2,MW^PSODIR2,RMK^PSODIR2,PSODRG
                EN^PSOFSIG
                MANUAL^PSONRXN
   PSORENW0     NOW^%DTC,FILE^DICN,DIE,DIK,$$GET1^DIQ,DIR,CAN^PSOCAN
                NOOR^PSOCAN4,PHGRP^PSOCLO1,DOSCK^PSODOSUT,POST^PSODRG
                SET^PSODRG,DCORD^PSONEW2,DE^PSOORFI2,EN^PSOORNE4,VER1^PSOORNE4
                PSOPTPST,PROFILE^PSOREF1,INST2^PSORENW,PSORENW1,KLIB^PSORENW1
                OERR^PSORENW1,STOP^PSORENW1,DSPLY^PSORENW3,INIT^PSORENW3
                EN^PSORN52,CHKPRV^PSOUTIL,NEXT^PSOUTIL,RENFDT^PSOUTIL
                RNPSOSD^PSOUTIL,STATUS^PSOUTIL,SUSDATEK^PSOUTIL,CLEAN^PSOVER1
                PSOL^PSSLOCK,PSOUL^PSSLOCK,FULL^VALM1,SETUP^XQALERT
   |opt         PSOCLOLS,AGAIN^PSOCLUTL,REG^PSOCLUTL,PSORXLAB

Routine             is Invoked by:
   C^%DTC              PSOCLO1,PSON52
   NOW^%DTC            PSOCLO1,PSON52,PSORENW0
   YMD^%DTC            PSOCLUTL
   T0^%ZOSV            PSON52
   T1^%ZOSV            PSON52
   ^DIC                PSOCLO1,PSOCLUTL
   MIX^DIC1            PSODRG
   FILE^DICN           PSON52,PSORENW0
   YN^DICN             PSOCLO1
   ^DIE                PSOCLUTL,PSODRG,PSON52,PSORENW0
   ^DIK                PSOCLO1,PSORENW0
   IX1^DIK             PSON52
   $$GET1^DIQ          PSODRG,PSON52,PSORENW0
   ^DIR                PSOCLO1,PSOCLUTL,PSODRG,PSORENW0
   ^DIWP               PSODRG
   $$SWSTAT^IBBAPI     PSON52
   $$SUBSCRIB^ORDEA    PSON52
   $$AOC^OROCAPI       PSODRG
   $$DOC^OROCAPI       PSODRG
   $$GOC^OROCAPI       PSODRG
   $$OITM^ORX8         PSODRG
   MSG1^PSJCLOZ        PSOCLO1
   MSG10^PSJCLOZ       PSOCLO1
   MSG3^PSJCLOZ        PSOCLO1
   MSG4^PSJCLOZ        PSOCLO1
   MSG5^PSJCLOZ        PSOCLO1
   MSG6^PSJCLOZ        PSOCLO1
   MSG9^PSJCLOZ        PSOCLO1
   PROVCHK^PSJCLOZ     PSOCLUTL
   ECMESND^PSOBPSU1    PSON52
   RXACT^PSOBPSU2      PSON52
   $$RXRLDT^PSOBPSUT   PSODRG
   $$STATUS^PSOBPSUT   PSODRG,PSON52
   $$SUBMIT^PSOBPSUT   PSON52
   ^PSOBUILD           PSODRG
   CAN^PSOCAN          PSORENW0
   NOOR^PSOCAN4        PSORENW0
   PHGRP^PSOCLO1       PSORENW0
   ^PSOCLOLS           |opt
   AGAIN^PSOCLUTL      |opt
   NUMBER1^PSOCLUTL    PSOCLO1
   REG^PSOCLUTL        |opt
   CK^PSOCROC          PSODRG
   HD^PSODDPR2         PSODRG
   DATACK^PSODDPRE     PSODRG
   ^PSODGAL1           PSODRG
   $$TECH2^PSODGDGP    PSON52
   EN^PSODIAG          PSONEW1
   ICD^PSODIAG         PSON52
   DOSE^PSODIR         PSONEW1
   INS^PSODIR          PSONEW1
   PROV^PSODIR         PSONEW1
   SINS^PSODIR         PSONEW1
   COPIES^PSODIR1      PSONEW1
   DAYS^PSODIR1        PSONEW1
   JUMP^PSODIR1        PSODRG
   PTSTAT^PSODIR1      PSONEW1
   QTY^PSODIR1         PSONEW1
   REFILL^PSODIR1      PSONEW1
   CLERK^PSODIR2       PSONEW1
   CLINIC^PSODIR2      PSONEW1
   EXP^PSODIR2         PSONEW1
   FILLDT^PSODIR2      PSONEW1
   ISSDT^PSODIR2       PSONEW1
   MW^PSODIR2          PSONEW1
   RMK^PSODIR2         PSONEW1
   DOSCK^PSODOSUT      PSORENW0
   ^PSODRG             PSONEW1
   POST^PSODRG         PSORENW0
   SET^PSODRG          PSORENW0
   EN^PSOFSIG          PSONEW1
   EN^PSOHLUP          PSOCLUTL
   $$GETNDC^PSONDCUT   PSODRG,PSON52
   NDCEDT^PSONDCUT     PSODRG
   NOOR^PSONEW         PSON52
   DCORD^PSONEW2       PSORENW0
   TD^PSONFI           PSODRG
   MANUAL^PSONRXN      PSONEW1
   DE^PSOORFI2         PSORENW0
   EN^PSOORNE4         PSORENW0
   VER1^PSOORNE4       PSORENW0
   ALLERGY^PSOORUT2    PSODRG
   GACT^PSOPFSU0       PSON52
   ^PSOPTPST           PSORENW0
   PROFILE^PSOREF1     PSORENW0
   $$PSOET^PSOREJP3    PSON52
   $$HDLG^PSOREJU1     PSON52
   $$FIND^PSOREJUT     PSODRG,PSON52
   INST2^PSORENW       PSORENW0
   ALERT^PSORENW0      PSON52
   ^PSORENW1           PSORENW0
   KLIB^PSORENW1       PSORENW0
   OERR^PSORENW1       PSORENW0
   STOP^PSORENW1       PSORENW0
   DSPLY^PSORENW3      PSORENW0
   INIT^PSORENW3       PSORENW0
   EN^PSORN52          PSORENW0
   BBRX^PSORN52C       PSON52
   ORC^PSORN52C        PSON52
   ^PSORXI             PSODRG
   DUPINV^PSORXI       PSODRG
   EN1^PSORXI          PSODRG
   SUS^PSORXL          PSON52
   ^PSORXLAB           |opt
   CHKPRV^PSOUTIL      PSORENW0
   NEXT^PSOUTIL        PSORENW0
   RENFDT^PSOUTIL      PSORENW0
   RNPSOSD^PSOUTIL     PSORENW0
   STATUS^PSOUTIL      PSORENW0
   SUSDATEK^PSOUTIL    PSORENW0
   PRFLP^PSOUTL        PSODRG
   CLEAN^PSOVER1       PSORENW0
   $$PROMPT^PSSDIN     PSODRG
   EN^PSSDIN           PSODRG
   $$DS^PSSDSAPI       PSON52
   IN^PSSHRQ2          PSODRG
   PSOL^PSSLOCK        PSORENW0
   PSOUL^PSSLOCK       PSON52,PSORENW0
   $$GETNDC^PSSNDCUT   PSODRG
   SAVNDC^PSSNDCUT     PSON52
   DEM^VADPT           PSODRG
   FULL^VALM1          PSORENW0
   $$SITE^VASITE       PSOCLO1
   $$FMTE^XLFDT        PSON52
   ^XMD                PSOCLO1,PSOCLUTL
   SETUP^XQALERT       PSORENW0
   ^YSCLSERV           PSOCLO1
   $$CL^YSCLTST2       PSOCLO1
   $$OVERRIDE^YSCLTST2 PSOCLO1
   CL1^YSCLTST2        PSOCLO1
   ^YSCLTST6           PSON52

*****   END   *****


--- END ---
